From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 29 Apr 2018 21:49:59 +0000 (-0700)
Subject: Clean up bundle implementation.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~94
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=eeb6fd1c573a011904996f98cc51b497771ae8a2;p=mit-scheme.git

Clean up bundle implementation.
---

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index f9151a905..ec15d37af 100644
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -31,60 +31,76 @@ USA.
 ;;; procedure to call, and the rest of the bundle's arguments are passed to the
 ;;; selected procedure.
 
-;;; Each bundle also carries a predicate that can be used to identify it.
-;;; Normally the predicate is shared between bundles with the same general
-;;; structure.
+;;; Each bundle also carries a type that can be used to identify it.  Normally
+;;; the type is shared between bundles with the same general structure.
 
 (declare (usual-integrations))
 
-(define (make-bundle-predicate name)
-  (letrec ((predicate
-            (lambda (object)
-              (and (bundle? object)
-                   (eq? predicate (bundle-predicate object))))))
-    (register-predicate! predicate name '<= bundle?)
-    predicate))
-
-(define (bundle-predicate? object)
-  (and (predicate? object)
-       (predicate<= object bundle?)))
-(register-predicate! bundle-predicate? 'bundle-predicate)
-
-;; Defer this because predicate? will change later in the cold load.
-(defer-boot-action 'predicate-relations
-  (lambda ()
-    (set-predicate<=! bundle-predicate? predicate?)))
-
-(define (alist->bundle predicate alist)
-  (guarantee bundle-predicate? predicate 'alist->bundle)
-  (guarantee bundle-alist? alist 'alist->bundle)
-  (%make-bundle predicate (alist-copy alist)))
-
-(define (bundle-alist? object)
+(define (make-bundle-type name #!optional parent-type)
+  (let ((type
+	 (new-make-record-type name
+			       '()
+			       (if (default-object? parent-type)
+				   <bundle>
+				   (guarantee bundle-type? parent-type
+					      'make-bundle-type)))))
+    (set-record-type-applicator! type %bundle-applicator)
+    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-unparser-method bundle-type?
+  (simple-unparser-method 'bundle-type
+    (lambda (type)
+      (list (dispatch-tag-name type)))))
+
+(define (bundle-predicate type)
+  (guarantee bundle-type? type 'bundle-predicate)
+  (record-predicate type))
+
+(define (alist->bundle type alist)
+  (guarantee bundle-type? type 'alist->bundle)
+  (guarantee %bundle-alist? alist 'alist->bundle)
+  ((record-constructor type) (alist-copy alist)))
+
+(define (%bundle-alist? object)
   (and (alist? object)
        (every (lambda (p)
                 (symbol? (car p)))
               object)))
 
 (define-record-type <bundle>
-    (%make-bundle predicate alist)
+    (%unused% alist) ;change to #f after 9.3 release
     bundle?
-  (predicate bundle-predicate)
   (alist bundle-alist))
 
-(set-record-type-applicator! <bundle>
-  (lambda (bundle operator . args)
-    (apply (bundle-ref bundle operator) args)))
-
 (define-unparser-method bundle?
   (standard-unparser-method
    (lambda (bundle)
-     (predicate-name (bundle-predicate bundle)))
+     (dispatch-tag-name (bundle-type bundle)))
    (lambda (bundle port)
      (let ((handler (bundle-ref bundle 'write-self #f)))
        (if handler
 	   (handler port))))))
 
+(define-pp-describer bundle?
+  (lambda (bundle)
+    (let ((handler (bundle-ref bundle 'describe-self #f)))
+      (if handler
+	  (handler)
+	  (map (lambda (p) `(,(car p) ,(cdr p)))
+	       (bundle-alist bundle))))))
+
+(define (bundle-type bundle)
+  (guarantee bundle? bundle 'bundle-type)
+  (record-type-descriptor bundle))
+
 (define (bundle->alist bundle)
   (alist-copy (bundle-alist bundle)))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 6ebceb187..0c557db51 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1929,10 +1929,11 @@ USA.
 	  bundle->alist
 	  bundle-names
 	  bundle-predicate
-	  bundle-predicate?
+	  bundle-type
+	  bundle-type?
 	  bundle-ref
 	  bundle?
-	  make-bundle-predicate))
+	  make-bundle-type))
 
 (define-package (runtime environment)
   (files "environment")
diff --git a/tests/runtime/test-bundle.scm b/tests/runtime/test-bundle.scm
index ea6546588..c61e6b6a8 100644
--- a/tests/runtime/test-bundle.scm
+++ b/tests/runtime/test-bundle.scm
@@ -30,14 +30,14 @@ USA.
 
 (define-test 'simple
   (lambda ()
-    (define foo? (make-bundle-predicate 'foo))
-
-    (assert-true (bundle-predicate? foo?))
+    (define <foo> (make-bundle-type 'foo))
+    (assert-true (bundle-type? <foo>))
+    (define foo? (bundle-predicate <foo>))
 
     (let ((x 10)
 	  (y 20)
 	  (z 40))
-      (let ((b (bundle foo? 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,8 +48,11 @@ USA.
 (define-test 'metadata-table
   (lambda ()
 
+    (define <metadata-table>
+      (make-bundle-type 'metadata-table))
+
     (define metadata-table?
-      (make-bundle-predicate 'metadata-table))
+      (bundle-predicate <metadata-table>))
 
     (define foo
       (let ((alist '()))
@@ -97,7 +100,7 @@ USA.
 		      (put! (car p) (cdr p)))
 		    alist*))
 
-	(bundle metadata-table?
+	(bundle <metadata-table>
 		has?
 		get
 		put!