From 84f06651d1205f1add6d68edad50402da13c8fc5 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 28 Apr 2018 22:41:08 -0700
Subject: [PATCH] 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.
---
 src/runtime/bundle.scm        | 264 ++++++++--------------------------
 src/runtime/make.scm          |   7 +-
 src/runtime/mit-macros.scm    |  49 +------
 src/runtime/predicate.scm     |   3 +-
 src/runtime/runtime.pkg       |  13 +-
 tests/runtime/test-bundle.scm |  70 ++++-----
 6 files changed, 95 insertions(+), 311 deletions(-)

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index 9b2a118ce..f9151a905 100644
--- 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))
 
-(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)))
-
-(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))
-
-(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))))
-
-(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 a1d61820d..4718734c9 100644
--- 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 a1c87cd74..7924179a7 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -757,46 +757,9 @@ USA.
 			   swap!
 			   (apply scons-lambda '() body-forms)
 			   swap!)))))))))
-
-(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 458d9b8b5..35590d14f 100644
--- 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?)))
 
 (add-boot-init!
  (lambda ()
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 834c4aeb1..6ebceb187 100644
--- 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 ae265d560..ea6546588 100644
--- a/tests/runtime/test-bundle.scm
+++ b/tests/runtime/test-bundle.scm
@@ -30,55 +30,26 @@ USA.
 
 (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))
 
-- 
2.25.1