From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 20 Jan 2018 05:23:08 +0000 (-0800)
Subject: Refactor the bundle implementation.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~332
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ea5cd2eaa80dfa90c1b23f2a04e9c8976a633bbd;p=mit-scheme.git

Refactor the bundle implementation.

* The interface is now the predicate rather than the tag.
* New procedures bundle-constructor and bundle-accessor.
* define-bundle-interface generates a BOA constructor and uses it.
---

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index 3db13b260..5cd06e346 100644
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -47,17 +47,16 @@ USA.
       ((predicate
 	(lambda (object)
 	  (and (bundle? object)
-	       (dispatch-tag<= (bundle-interface object) tag))))
+	       (dispatch-tag<= (%bundle-tag object) tag))))
        (tag
-	(let ((elements (sort-alist elements)))
-	  (%make-bundle-interface name
-				  predicate
-				  (list->vector (map car elements))
-				  (list->vector (map (lambda (element)
-						       (map list-copy
-							    (cdr element)))
-						     elements))))))
-    tag))
+	(make-bundle-interface-tag name
+				   predicate
+				   (list->vector (map car elements))
+				   (list->vector (map (lambda (element)
+							(map list-copy
+							     (cdr element)))
+						      elements)))))
+    predicate))
 
 (define (elements? object)
   (and (list? object)
@@ -74,130 +73,178 @@ USA.
        (alist-has-unique-keys? object)))
 (register-predicate! elements? 'interface-elements)
 
-(define bundle-interface?)
-(define %make-bundle-interface)
+(define bundle-interface-tag?)
+(define make-bundle-interface-tag)
 (add-boot-init!
  (lambda ()
    (let ((metatag (make-dispatch-metatag 'bundle-interface)))
-     (set! bundle-interface? (dispatch-tag->predicate metatag))
-     (set! %make-bundle-interface
+     (set! bundle-interface-tag? (dispatch-tag->predicate metatag))
+     (set! make-bundle-interface-tag
 	   (dispatch-metatag-constructor metatag 'make-bundle-interface))
      unspecific)))
 
-(define-integrable (%bundle-interface-element-names interface)
-  (dispatch-tag-extra interface 0))
+(define (bundle-interface? object)
+  (and (predicate? object)
+       (bundle-interface-tag? (predicate->dispatch-tag object))))
 
-(define-integrable (%bundle-interface-element-properties interface)
-  (dispatch-tag-extra interface 1))
+(define-integrable (tag-element-names tag)
+  (dispatch-tag-extra tag 0))
+
+(define-integrable (tag-element-properties tag)
+  (dispatch-tag-extra 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)
-  (vector->list (%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)
-  (map list-copy
-       (vector-ref (%bundle-interface-element-properties interface)
-		   (element-index interface name #t))))
+  (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 interface name required?)
+(define (element-index tag name required?)
   (let ((index
-	 (let ((v (%bundle-interface-element-names interface)))
-	   (let loop ((start 0) (end (vector-length v)))
-	     (and (fix:< start end)
-		  (let* ((midpoint (fix:quotient (fix:+ start end) 2))
-			 (name* (vector-ref v midpoint)))
-		    (cond ((symbol<? name name*) (loop start midpoint))
-			  ((symbol<? name* name) (loop (fix:+ midpoint 1) end))
-			  (else midpoint))))))))
+	 (let* ((v (tag-element-names tag))
+		(end (vector-length v)))
+	   (let loop ((i 0))
+	     (and (fix:< i end)
+		  (if (eq? name (vector-ref v i))
+		      i
+		      (loop (fix:+ i 1))))))))
     (if (not (or index (not required?)))
-	(error "Unknown element name:" name interface))
+	(error "Unknown element name:" name (dispatch-tag->predicate tag)))
     index))
 
 (define (bundle? object)
   (and (entity? object)
        (bundle-metadata? (entity-extra object))))
 
-(define (make-bundle interface alist)
-  (guarantee bundle-interface? interface 'make-bundle)
-  (guarantee bundle-alist? alist 'make-bundle)
+(add-boot-init!
+ (lambda ()
+   (register-predicate! bundle? 'bundle '<= entity?)))
+
+(define (%make-bundle tag values)
   (make-entity (lambda (self operator . args)
 		 (apply (bundle-ref self operator) args))
-	       (make-bundle-metadata interface
-				     (bundle-alist->values interface alist))))
-
-(define (bundle-alist->values interface alist)
-  (let ((n (vector-length (%bundle-interface-element-names interface))))
-    (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 interface (car p) #t)
-			       (cdr p)))
-		alist)
-      values)))
-
-(define (bundle-alist? object)
-  (and (alist? object)
-       (every (lambda (p)
-		(symbol? (car p)))
-	      object)
-       (alist-has-unique-keys? object)))
-(register-predicate! bundle-alist? 'bundle-alist '<= alist?)
+	       (make-bundle-metadata tag values)))
 
 (define-record-type <bundle-metadata>
-    (make-bundle-metadata interface values)
+    (make-bundle-metadata tag values)
     bundle-metadata?
-  (interface bundle-metadata-interface)
+  (tag bundle-metadata-tag)
   (values bundle-metadata-values))
 
-(add-boot-init!
- (lambda ()
-   (register-predicate! bundle? 'bundle '<= entity?)))
-
-(define (bundle-interface bundle)
-  (bundle-metadata-interface (entity-extra bundle)))
+(define (%bundle-tag bundle)
+  (bundle-metadata-tag (entity-extra bundle)))
 
 (define (%bundle-values bundle)
   (bundle-metadata-values (entity-extra bundle)))
 
+(define (bundle-interface bundle)
+  (guarantee bundle? bundle 'bundle-interface)
+  (dispatch-tag->predicate (%bundle-tag bundle)))
+
 (define (bundle-names bundle)
-  (bundle-interface-element-names (bundle-interface bundle)))
+  (guarantee bundle? bundle 'bundle-names)
+  (vector->list (tag-element-names (%bundle-tag bundle))))
 
-(define (bundle-alist bundle)
+(define (bundle->alist bundle)
+  (guarantee bundle? bundle 'bundle->alist)
   (map cons
-       (bundle-names bundle)
+       (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-interface bundle)
+	 (element-index (%bundle-tag bundle)
 			operator
 			(default-object? default))))
     (if index
 	(vector-ref (%bundle-values bundle) index)
         default)))
-
-(define (alist-has-unique-keys? alist)
-  (or (null? alist)
-      (and (not (any (let ((name (caar alist)))
-		       (lambda (p)
-			 (eq? name (car p))))
-		     (cdr alist)))
-	   (alist-has-unique-keys? (cdr alist)))))
-
-(define (sort-alist alist)
-  (sort alist
-	(lambda (a b)
-	  (symbol<? (car a) (car b)))))
 
 (define-unparser-method bundle?
   (standard-unparser-method
    (lambda (bundle)
-     (dispatch-tag-name (bundle-interface 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))))
\ No newline at end of file
+	 (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))))
+
+(define (bundle-alist? object)
+  (and (alist? object)
+       (every (lambda (p)
+		(symbol? (car p)))
+	      object)
+       (alist-has-unique-keys? object)))
+(register-predicate! bundle-alist? 'bundle-alist '<= alist?)
+
+(define (alist-has-unique-keys? alist)
+  (or (null? alist)
+      (and (not (any (let ((name (caar alist)))
+		       (lambda (p)
+			 (eq? name (car p))))
+		     (cdr alist)))
+	   (alist-has-unique-keys? (cdr alist)))))
\ No newline at end of file
diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 2c319cc65..34f513203 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -778,24 +778,28 @@ USA.
 			    (cadddr form)
 			    (cddddr form)))))
 
-(define (make-interface-helper rename interface capturer predicate elements)
+(define (make-interface-helper rename interface constructor capturer elements)
   (let ((rlist (rename 'list)))
     `(,(rename 'begin)
       (,(rename 'define)
        ,interface
-	(,(rename 'make-bundle-interface)
-	 ',(strip-angle-brackets interface)
-	 (,rlist ,@(map (lambda (element)
-			  (if (symbol? element)
-			      `(,rlist ',element)
-			      `(,rlist ',(car element)
-				       ,@(map (lambda (p)
-						`(,rlist ',(car p) ,@(cdr p)))
-					      (cdr element)))))
-			elements))))
+       (,(rename '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))
+	(,rlist ,@(map (lambda (element)
+			 (if (symbol? element)
+			     `(,rlist ',element)
+			     `(,rlist ',(car element)
+				      ,@(map (lambda (p)
+					       `(,rlist ',(car p) ,@(cdr p)))
+					     (cdr element)))))
+		       elements))))
       (,(rename 'define)
-       ,predicate
-	(,(rename 'dispatch-tag->predicate) ,interface))
+       ,constructor
+	(,(rename 'bundle-constructor) ,interface))
       (,(rename 'define-syntax)
        ,capturer
        (,(rename 'sc-macro-transformer)
@@ -803,18 +807,11 @@ USA.
 	 (form use-env)
 	 (if (,(rename 'not) (,(rename 'null?) (,(rename 'cdr) form)))
 	     (,(rename 'syntax-error) "Ill-formed special form:" form))
-	 (,rlist 'capture-bundle
-		 ',interface
+	 (,rlist ',constructor
 		 ,@(map (lambda (element)
 			  `(,(rename 'close-syntax)
 			    ',(if (symbol? element)
 				  element
 				  (car element))
 			    use-env))
-			elements))))))))
-
-(define-syntax :capture-bundle
-  (syntax-rules ()
-    ((_ interface name ...)
-     (make-bundle interface
-                  (list (cons 'name name) ...)))))
\ No newline at end of file
+			elements))))))))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 8327cbe19..13b66f32f 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1924,15 +1924,18 @@ USA.
   (files "bundle")
   (parent (runtime))
   (export ()
-	  bundle-alist
+	  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-ref
 	  bundle?
-	  make-bundle
 	  make-bundle-interface))
 
 (define-package (runtime environment)
@@ -4661,7 +4664,6 @@ USA.
 	  (and-let* :and-let*)
 	  (assert :assert)
 	  (begin0 :begin0)
-	  (capture-bundle :capture-bundle)
 	  (case :case)
 	  (circular-stream :circular-stream)
 	  (cond :cond)