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 3db13b260ade964e5953e1621c50abe5b4918df7..5cd06e346107401ece49058d7789103b3df78af5 100644 (file)
--- 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))
 \f
 (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)))
-\f
-(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))))
+\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))))
+
+(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 2c319cc65ea0612ca4a77607340d5794ddc736a9..34f5132032e72df28d0dd432a3aebc8fcc8ef48b 100644 (file)
--- 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 8327cbe19bbe5d55ba9e5c688f7a7eaa7a612063..13b66f32fba1712bfb812cd12001e34cfef9f08c 100644 (file)
--- 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)