From: Chris Hanson Date: Mon, 30 Apr 2018 18:59:57 +0000 (-0700) Subject: Eliminate bundle types; original design using predicates is better. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~89 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1999db7c5f5bb50f03e854b9920fc7ed7147c60c;p=mit-scheme.git Eliminate bundle types; original design using predicates is better. --- diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm index d2bf7ec1e..2dc34a890 100644 --- a/src/runtime/bundle.scm +++ b/src/runtime/bundle.scm @@ -36,45 +36,45 @@ USA. (declare (usual-integrations)) -(define (make-bundle-type name #!optional parent-type) +(define (make-bundle-predicate name #!optional parent-predicate) (let ((type (new-make-record-type name '() - (if (default-object? parent-type) + (if (default-object? parent-predicate) - (guarantee bundle-type? parent-type - 'make-bundle-type))))) + (%predicate->record-type + (guarantee bundle-predicate? + parent-predicate + 'make-bundle-predicate)))))) (set-record-type-applicator! type %bundle-applicator) - type)) + (record-predicate type))) (define (%bundle-applicator bundle operator . args) (apply (bundle-ref bundle operator) args)) -(define (bundle-type? object) - (and (record-type? object) - (predicate<= (record-predicate object) bundle?))) -(register-predicate! bundle-type? 'bundle-type '<= record-type?) +(define-integrable (%predicate->record-type predicate) + (predicate->dispatch-tag predicate)) -(define-unparser-method bundle-type? - (simple-unparser-method 'bundle-type - (lambda (type) - (list (dispatch-tag-name type))))) +(define (bundle-predicate? object) + (and (predicate? object) + (predicate<= object bundle?))) -(define (bundle-predicate type) - (guarantee bundle-type? type 'bundle-predicate) - (record-predicate type)) +(defer-boot-action 'predicate-relations + (lambda () + (register-predicate! bundle-predicate? 'bundle-predicate '<= predicate?))) -(define (alist->bundle type alist) +(define (alist->bundle predicate alist) (guarantee %bundle-alist? alist 'alist->bundle) - ((record-constructor type) (alist-copy alist))) + ((record-constructor (%predicate->record-type predicate)) (alist-copy alist))) (defer-boot-action 'predicate-relations (lambda () (set! alist->bundle - (named-lambda (alist->bundle type alist) - (guarantee bundle-type? type 'alist->bundle) + (named-lambda (alist->bundle predicate alist) + (guarantee bundle-predicate? predicate 'alist->bundle) (guarantee %bundle-alist? alist 'alist->bundle) - ((record-constructor type) (alist-copy alist)))) + ((record-constructor (%predicate->record-type predicate)) + (alist-copy alist)))) unspecific)) (define (%bundle-alist? object) @@ -91,7 +91,7 @@ USA. (define-unparser-method bundle? (standard-unparser-method (lambda (bundle) - (dispatch-tag-name (bundle-type bundle))) + (record-type-name (record-type-descriptor bundle))) (lambda (bundle port) (let ((handler (bundle-ref bundle 'write-self #f))) (if handler @@ -105,9 +105,9 @@ USA. (map (lambda (p) `(,(car p) ,(cdr p))) (bundle-alist bundle)))))) -(define (bundle-type bundle) +(define (bundle-predicate bundle) (guarantee bundle? bundle 'bundle-type) - (record-type-descriptor bundle)) + (record-predicate (record-type-descriptor bundle))) (define (bundle->alist bundle) (alist-copy (bundle-alist bundle))) diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 202671067..4dda86f43 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -494,8 +494,8 @@ USA. ;;;; Metadata tables -(define - (make-bundle-type 'metadata-table)) +(define metadata-table? + (make-bundle-predicate 'metadata-table)) (define (make-alist-metadata-table) (let ((alist '())) @@ -543,7 +543,7 @@ USA. (put! (car p) (cdr p))) alist*)) - (bundle + (bundle metadata-table? has? get put! intern! delete! get-alist put-alist!))) (define (make-hashed-metadata-table) @@ -574,7 +574,7 @@ USA. (put! (car p) (cdr p))) alist*)) - (bundle + (bundle metadata-table? has? get put! intern! delete! get-alist put-alist!))) ;;;; Builder for vector-like sequences diff --git a/src/runtime/hash.scm b/src/runtime/hash.scm index 6b5655eca..8f7115cd0 100644 --- a/src/runtime/hash.scm +++ b/src/runtime/hash.scm @@ -56,10 +56,9 @@ USA. (define (->hasher hasher caller) (if (default-object? hasher) default-object-hasher - (guarantee hasher? hasher caller))) + (guarantee object-hasher? hasher caller))) -(define-deferred (make-bundle-type 'object-hasher)) -(define-deferred object-hasher? (bundle-predicate )) +(define-deferred object-hasher? (make-bundle-predicate 'object-hasher)) (define-deferred default-object-hasher (make-object-hasher 313)) (define (make-object-hasher #!optional initial-size) @@ -101,5 +100,5 @@ USA. (lambda () (hash-table-exists? unhash-table hash))))) - (bundle + (bundle object-hasher? hash-object object-hashed? unhash-object valid-object-hash?))) \ No newline at end of file diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index f1eb12622..d60ba44a5 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1929,11 +1929,10 @@ USA. bundle->alist bundle-names bundle-predicate - bundle-type - bundle-type? + bundle-predicate? bundle-ref bundle? - make-bundle-type)) + make-bundle-predicate)) (define-package (runtime environment) (files "environment") diff --git a/tests/runtime/test-bundle.scm b/tests/runtime/test-bundle.scm index c61e6b6a8..3eb0ce12c 100644 --- a/tests/runtime/test-bundle.scm +++ b/tests/runtime/test-bundle.scm @@ -30,14 +30,13 @@ USA. (define-test 'simple (lambda () - (define (make-bundle-type 'foo)) - (assert-true (bundle-type? )) - (define foo? (bundle-predicate )) + (define foo? (make-bundle-predicate 'foo)) + (assert-true (bundle-predicate? foo?)) (let ((x 10) (y 20) (z 40)) - (let ((b (bundle x y z))) + (let ((b (bundle foo? x y z))) (assert-true (foo? b)) (assert-eqv (bundle-ref b 'x) x) (assert-eqv (bundle-ref b 'y) y) @@ -48,11 +47,8 @@ USA. (define-test 'metadata-table (lambda () - (define - (make-bundle-type 'metadata-table)) - (define metadata-table? - (bundle-predicate )) + (make-bundle-predicate 'metadata-table)) (define foo (let ((alist '())) @@ -100,7 +96,7 @@ USA. (put! (car p) (cdr p))) alist*)) - (bundle + (bundle metadata-table? has? get put!