Revert bundle abstraction back to what we are using the in the book.

The previous version didn't really do what I wanted and this one is useful in a
more limited context.

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index 9b2a118ce1737d905f448d1de8bd7aaa200fcb29..f9151a90599528a7704ba962a19d53b8d2444b60 100644 (file)
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -26,226 +26,76 @@ USA.
 
 ;;;; Bundles
 
-;;; A bundle is a set of named elements.  The name and metadata properties of
-;;; each element are specified by an interface.  Each metadata property consists
-;;; of a symbol identifying the property and some objects that are the property
-;;; values.  While some metadata properties will be defined and used by the
-;;; bundle implementation, any property can be specified and will be carried
-;;; along in the interface.
-;;;
-;;; It is anticipated that most bundle elements will be procedures.  For
-;;; convenience, the bundle is itself implemented as a procedure.  The first
-;;; argument to the bundle is a symbol identifying the named object to call, and
-;;; the rest of the bundle's arguments are passed to the selected procedure.
+;;; A bundle is a set of named procedures implemented as a procedure.  When
+;;; called, the first argument to the bundle is a symbol identifying the named
+;;; 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.
 
 (declare (usual-integrations))
 \f
-(define (make-bundle-interface name elements)
-  (guarantee symbol? name 'make-bundle-interface)
-  (guarantee elements? elements 'make-bundle-interface)
-  (letrec*
-      ((predicate
-       (lambda (object)
-         (and (bundle? object)
-              (eq? tag (%bundle-tag object)))))
-       (tag
-       (make-bundle-interface-tag name
-                                  predicate
-                                  (list->vector (map element-name elements))
-                                  (list->vector
-                                   (map (lambda (element)
-                                          (map list-copy
-                                               (element-properties element)))
-                                        elements)))))
+(define (make-bundle-predicate name)
+  (letrec ((predicate
+            (lambda (object)
+              (and (bundle? object)
+                   (eq? predicate (bundle-predicate object))))))
+    (register-predicate! predicate name '<= bundle?)
     predicate))
 
-(define (elements? object)
-  (and (list? object)
-       (every (lambda (p)
-               (or (symbol? p)
-                   (and (pair? p)
-                        (symbol? (car p))
-                        (list? (cdr p))
-                        (every (lambda (r)
-                                 (and (pair? r)
-                                      (symbol? (car r))
-                                      (list? (cdr r))))
-                               (cdr p)))))
-             object)
-       (no-duplicate-keys? object element-name)))
-(register-predicate! elements? 'interface-elements)
-
-(define (element-name element)
-  (if (symbol? element)
-      element
-      (car element)))
-
-(define (element-properties element)
-  (if (symbol? element)
-      '()
-      (cdr element)))
-\f
-(define bundle-interface-tag?)
-(define make-bundle-interface-tag)
-(add-boot-init!
- (lambda ()
-   (let ((metatag (make-dispatch-metatag 'bundle-interface)))
-     (set! bundle-interface-tag? (dispatch-tag->predicate metatag))
-     (set! make-bundle-interface-tag
-          (dispatch-metatag-constructor metatag 'make-bundle-interface))
-     unspecific)))
-
-(define (bundle-interface? object)
+(define (bundle-predicate? object)
   (and (predicate? object)
-       (bundle-interface-tag? (predicate->dispatch-tag object))))
-
-(define-integrable (tag-element-names tag)
-  (dispatch-tag-extra-ref tag 0))
-
-(define-integrable (tag-element-properties tag)
-  (dispatch-tag-extra-ref tag 1))
-
-(define (bundle-interface-name interface)
-  (guarantee bundle-interface? interface 'bundle-interface-name)
-  (dispatch-tag-name (predicate->dispatch-tag interface)))
-
-(define (bundle-interface-element-names interface)
-  (guarantee bundle-interface? interface 'bundle-interface-element-names)
-  (vector->list (tag-element-names (predicate->dispatch-tag interface))))
-
-(define (bundle-interface-element-properties interface name)
-  (guarantee bundle-interface? interface 'bundle-interface-element-properties)
-  (let ((tag (predicate->dispatch-tag interface)))
-    (map list-copy
-        (vector-ref (tag-element-properties tag)
-                    (element-index tag name #t)))))
-
-(define (element-index tag name required?)
-  (let ((index (vector-find-next-element (tag-element-names tag) name)))
-    (if (not (or index (not required?)))
-       (error "Unknown element name:" name (dispatch-tag->predicate tag)))
-    index))
-\f
-(define (bundle? object)
-  (and (entity? object)
-       (let ((extra (entity-extra object)))
-        (and (vector? extra)
-             (fix:= 2 (vector-length extra))
-             (bundle-interface-tag? (vector-ref extra 0))))))
-
-(define (%make-bundle tag values)
-  (make-entity (lambda (self operator . args)
-                (apply (bundle-ref self operator) args))
-              (vector tag values)))
+       (predicate<= object bundle?)))
+(register-predicate! bundle-predicate? 'bundle-predicate)
 
-(define-integrable (%bundle-tag bundle)
-  (vector-ref (entity-extra bundle) 0))
+;; Defer this because predicate? will change later in the cold load.
+(defer-boot-action 'predicate-relations
+  (lambda ()
+    (set-predicate<=! bundle-predicate? predicate?)))
 
-(define-integrable (%bundle-values bundle)
-  (vector-ref (entity-extra bundle) 1))
+(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-interface bundle)
-  (guarantee bundle? bundle 'bundle-interface)
-  (dispatch-tag->predicate (%bundle-tag bundle)))
+(define (bundle-alist? object)
+  (and (alist? object)
+       (every (lambda (p)
+                (symbol? (car p)))
+              object)))
 
-(define (bundle-names bundle)
-  (guarantee bundle? bundle 'bundle-names)
-  (vector->list (tag-element-names (%bundle-tag bundle))))
+(define-record-type <bundle>
+    (%make-bundle predicate alist)
+    bundle?
+  (predicate bundle-predicate)
+  (alist bundle-alist))
 
-(define (bundle->alist bundle)
-  (guarantee bundle? bundle 'bundle->alist)
-  (map cons
-       (vector->list (tag-element-names (%bundle-tag bundle)))
-       (vector->list (%bundle-values bundle))))
-
-(define (bundle-ref bundle operator #!optional default)
-  (guarantee bundle? bundle 'bundle-ref)
-  (let ((index
-        (element-index (%bundle-tag bundle)
-                       operator
-                       (default-object? default))))
-    (if index
-       (vector-ref (%bundle-values bundle) index)
-        default)))
+(set-record-type-applicator! <bundle>
+  (lambda (bundle operator . args)
+    (apply (bundle-ref bundle operator) args)))
 
 (define-unparser-method bundle?
   (standard-unparser-method
    (lambda (bundle)
-     (dispatch-tag-name (%bundle-tag bundle)))
-   #f))
-
-(define-pp-describer bundle?
-  (lambda (bundle)
-    (map (lambda (name)
-          (list name (bundle-ref bundle name)))
-        (bundle-names bundle))))
-\f
-(define (bundle-constructor interface)
-  (guarantee bundle-interface? interface 'bundle-constructor)
-  (let* ((tag (predicate->dispatch-tag interface))
-        (n (vector-length (tag-element-names tag))))
-    (let-syntax
-       ((expand-cases
-         (sc-macro-transformer
-          (lambda (form environment)
-            (let ((limit (cadr form))
-                  (default (caddr form))
-                  (make-name
-                   (lambda (i)
-                     (intern (string-append "v" (number->string i))))))
-              (let loop ((i 0) (names '()))
-                (if (fix:< i limit)
-                    `(if (fix:= n ,i)
-                         (lambda (,@names) (%make-bundle tag (vector ,@names)))
-                         ,(loop (fix:+ i 1)
-                                (append names (list (make-name i)))))
-                    default)))))))
-      (expand-cases 16
-       (letrec
-           ((constructor
-             (lambda args
-               (if (not (fix:= n (length args)))
-                   (error:wrong-number-of-arguments constructor n args))
-               (%make-bundle interface (list->vector args)))))
-         constructor)))))
-
-(define (bundle-accessor interface name)
-  (guarantee bundle-interface? interface 'bundle-accessor)
-  (let ((index (element-index (predicate->dispatch-tag interface) name #t)))
-    (lambda (bundle)
-      (guarantee interface bundle)
-      (vector-ref (%bundle-values bundle) index))))
-
-(define (alist->bundle interface alist)
-  (guarantee bundle-interface? interface 'alist->bundle)
-  (guarantee bundle-alist? alist 'alist->bundle)
-  (let* ((tag (predicate->dispatch-tag interface))
-        (n (vector-length (tag-element-names tag))))
-    (if (not (fix:= (length alist) n))
-       (error "Bundle alist doesn't match its elements:" alist interface))
-    (let ((values (make-vector n)))
-      (for-each (lambda (p)
-                 (vector-set! values
-                              (element-index tag (car p) #t)
-                              (cdr p)))
-               alist)
-      (%make-bundle tag values))))
+     (predicate-name (bundle-predicate bundle)))
+   (lambda (bundle port)
+     (let ((handler (bundle-ref bundle 'write-self #f)))
+       (if handler
+          (handler port))))))
 
-(define (bundle-alist? object)
-  (and (alist? object)
-       (every (lambda (p)
-               (symbol? (car p)))
-             object)
-       (no-duplicate-keys? object car)))
-(register-predicate! bundle-alist? 'bundle-alist '<= alist?)
-
-(define (alist-has-unique-keys? alist)
-  (no-duplicate-keys? alist car))
-
-(define (no-duplicate-keys? items get-key)
-  (or (null? items)
-      (and (not (any (let ((key (get-key (car items))))
-                      (lambda (item)
-                        (eq? key (get-key item))))
-                    (cdr items)))
-          (no-duplicate-keys? (cdr items) get-key))))
\ No newline at end of file
+(define (bundle->alist bundle)
+  (alist-copy (bundle-alist bundle)))
+
+(define (bundle-names bundle)
+  (map car (bundle-alist bundle)))
+
+(define (bundle-ref bundle operator #!optional default)
+  (let ((p (assq operator (bundle-alist bundle))))
+    (if p
+        (cdr p)
+        (begin
+          (if (default-object? default)
+              (error "Unknown bundle operator:" operator))
+          default))))
\ No newline at end of file

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index a1d61820dbe8bfa0797077c4f14dbf2349714aa6..4718734c98e2ac782356a1e7d6c1ba713c31bf72 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -371,10 +371,10 @@ USA.
         ("random" . (runtime random-number))
         ("dispatch-tag" . (runtime tagged-dispatch))
         ("poplat" . (runtime population))
-        ("record" . (runtime record))
-        ("bundle" . (runtime bundle))))
+        ("record" . (runtime record))))
       (files2
-       '(("syntax-low" . (runtime syntax low))
+       '(("bundle" . (runtime bundle))
+        ("syntax-low" . (runtime syntax low))
         ("thread" . (runtime thread))
         ("wind" . (runtime state-space))
         ("prop1d" . (runtime 1d-property))
@@ -409,7 +409,6 @@ USA.
   (package-initialize '(runtime tagged-dispatch) #f #t)
   (package-initialize '(runtime population) #f #t)
   (package-initialize '(runtime record) #f #t)
-  (package-initialize '(runtime bundle) #f #t)
 
   (load-files-with-boot-inits files2)
   (package-initialize '(runtime 1d-property) #f #t)         ;First population.

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index a1c87cd7441159334a9625f53b77238977ee0f54..7924179a71a4f74da9ec54907b8999fd36c43edc 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -757,46 +757,9 @@ USA.
                           swap!
                           (apply scons-lambda '() body-forms)
                           swap!)))))))))
-\f
-(define-syntax $define-bundle-interface
-  (sc-macro-transformer
-   (lambda (form use-env)
-     (syntax-check '(_ identifier identifier identifier
-                      * (or symbol (symbol * (symbol * expression))))
-                  form)
-     (make-interface-helper (close-syntax (cadr form) use-env)
-                           (close-syntax (caddr form) use-env)
-                           (close-syntax (cadddr form) use-env)
-                           (cddddr form)))))
-
-(define (make-interface-helper interface constructor capturer elements)
-  `(begin
-     (define ,interface
-       (make-bundle-interface
-       ',(let* ((name (identifier->symbol interface))
-                (s (symbol->string name)))
-           (if (string-suffix? "?" s)
-               (string->symbol (string-head s (fix:- (string-length s) 1)))
-               name))
-       (list ,@(map (lambda (element)
-                      (if (symbol? element)
-                          `',element
-                          `(list ',(car element)
-                                 ,@(map (lambda (p)
-                                          `(list ',(car p) ,@(cdr p)))
-                                        (cdr element)))))
-                    elements))))
-     (define ,constructor
-       (bundle-constructor ,interface))
-     (define-syntax ,capturer
-       (sc-macro-transformer
-       (lambda (form use-env)
-         (syntax-check '(_) form)
-         (list (quote-identifier ,constructor)
-               ,@(map (lambda (element)
-                        `(close-syntax
-                          ',(if (symbol? element)
-                                element
-                                (car element))
-                          use-env))
-                      elements)))))))
\ No newline at end of file
+
+(define-syntax $bundle
+  (syntax-rules ()
+    ((_ predicate name ...)
+     (alist->bundle predicate
+                  (list (cons 'name name) ...)))))
\ No newline at end of file

diff --git a/src/runtime/predicate.scm b/src/runtime/predicate.scm
index 458d9b8b57744d7a16f0fe605e110a90c1652383..35590d14fc25669b1ec12b4de1b665e9053a00ca 100644 (file)
--- a/src/runtime/predicate.scm
+++ b/src/runtime/predicate.scm
@@ -239,8 +239,7 @@ USA.
    (register-predicate! procedure-arity? 'procedure-arity)
    (register-predicate! thunk? 'thunk '<= procedure?)
    (register-predicate! unary-procedure? 'unary-procedure '<= procedure?)
-   (register-predicate! unparser-method? 'unparser-method '<= procedure?)
-   (register-predicate! bundle? 'bundle '<= entity?)))
+   (register-predicate! unparser-method? 'unparser-method '<= procedure?)))
 \f
 (add-boot-init!
  (lambda ()

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 834c4aeb10452dc2254e46882448fa55202f7ac6..6ebceb187218bdf530a53f670f99c9d0fdb5541c 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1927,17 +1927,12 @@ USA.
   (export ()
          alist->bundle
          bundle->alist
-         bundle-accessor
-         bundle-constructor
-         bundle-interface
-         bundle-interface-element-names
-         bundle-interface-element-properties
-         bundle-interface-name
-         bundle-interface?
          bundle-names
+         bundle-predicate
+         bundle-predicate?
          bundle-ref
          bundle?
-         make-bundle-interface))
+         make-bundle-predicate))
 
 (define-package (runtime environment)
   (files "environment")
@@ -4725,6 +4720,7 @@ USA.
          (and-let* $and-let*)
          (assert $assert)
          (begin0 $begin0)
+         (bundle $bundle)
          (case $case)
          (circular-stream $circular-stream)
          (cond $cond)
@@ -4733,7 +4729,6 @@ USA.
          (cons-stream* $cons-stream*)
          (define $define)
          (define-integrable $define-integrable)
-         (define-bundle-interface $define-bundle-interface)
          (define-record-type $define-record-type)
          (do $do)
          (fluid-let $fluid-let)

diff --git a/tests/runtime/test-bundle.scm b/tests/runtime/test-bundle.scm
index ae265d5600b5e2d021f56b4e14cc56549b8b0263..ea6546588cc03d8c56005f702711fca5b4c69888 100644 (file)
--- a/tests/runtime/test-bundle.scm
+++ b/tests/runtime/test-bundle.scm
@@ -30,55 +30,26 @@ USA.
 \f
 (define-test 'simple
   (lambda ()
-    (define-bundle-interface foo? make-foo capture-foo a b c)
-
-    (assert-true (bundle-interface? foo?))
-    (assert-equal (bundle-interface-element-names foo?)
-                 '(a b c))
-    (for-each (lambda (name)
-               (assert-equal (bundle-interface-element-properties foo? name)
-                             '()))
-             (bundle-interface-element-names foo?))
-
-    (define bundle-a (bundle-accessor foo? 'a))
-    (define bundle-b (bundle-accessor foo? 'b))
-    (define bundle-c (bundle-accessor foo? 'c))
-    (assert-error (lambda () (bundle-accessor foo 'd)))
-
-    (define (test-bundle bundle av bv cv)
-      (assert-true (foo? bundle))
-      (assert-eqv (bundle-ref bundle 'a) av)
-      (assert-eqv (bundle-ref bundle 'b) bv)
-      (assert-eqv (bundle-ref bundle 'c) cv)
-      (assert-eqv (bundle-ref bundle 'd #f) #f)
-      (assert-error (lambda () (bundle-ref foo 'd)))
-      (assert-eqv (bundle-a bundle) av)
-      (assert-eqv (bundle-b bundle) bv)
-      (assert-eqv (bundle-c bundle) cv))
-
-    (let ((a 10)
-         (b 20)
-         (c 40))
-      (test-bundle (make-foo a b c) a b c))
-
-    (let ((a 0)
-         (b 1)
-         (c 3))
-      (test-bundle (capture-foo) a b c))))
+    (define foo? (make-bundle-predicate 'foo))
+
+    (assert-true (bundle-predicate? foo?))
+
+    (let ((x 10)
+         (y 20)
+         (z 40))
+      (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)
+       (assert-eqv (bundle-ref b 'z) z)
+       (assert-eqv (bundle-ref b 'w #f) #f)
+       (assert-error (lambda () (bundle-ref foo 'w)))))))
 
 (define-test 'metadata-table
   (lambda ()
 
-    (define-bundle-interface metadata-table?
-      make-metadata-table
-      capture-metadata-table
-      has?
-      get
-      put!
-      intern!
-      delete!
-      get-alist
-      put-alist!)
+    (define metadata-table?
+      (make-bundle-predicate 'metadata-table))
 
     (define foo
       (let ((alist '()))
@@ -126,7 +97,14 @@ USA.
                      (put! (car p) (cdr p)))
                    alist*))
 
-       (capture-metadata-table)))
+       (bundle metadata-table?
+               has?
+               get
+               put!
+               intern!
+               delete!
+               get-alist
+               put-alist!)))
 
     (assert-true (metadata-table? foo))