Implement bundle delegation using a more general combinator mechanism.

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index c6cc691437e4ec1f1892f77e6fb8018a7abcd1fb..badd8e952eeccc10b1fa0ea1dd4d8b3bc18c8bdd 100644 (file)
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -41,8 +41,8 @@ USA.
     (set-record-type-applicator! type %bundle-applicator)
     (record-predicate type)))
 
-(define (%bundle-applicator bundle operator . args)
-  (apply (bundle-ref bundle operator) args))
+(define (%bundle-applicator bundle name . args)
+  (apply (bundle-ref bundle name) args))
 
 (define-integrable (%predicate->record-type predicate)
   (predicate->dispatch-tag predicate))
@@ -57,21 +57,11 @@ USA.
 
 (define (alist->bundle predicate alist)
   (guarantee %bundle-alist? alist 'alist->bundle)
-  (let ((constructor
-        (record-constructor
-         (if predicate
-             (%bundle-predicate->record-type predicate)
-             <bundle>))))
-   (let* ((alist (alist-copy alist))
-         (p (assq delegate-name alist)))
-     (if p
-        (begin
-          (guarantee binary-procedure? (cdr p) 'alist->bundle)
-          (constructor (delq delegate-name alist) (cdr p)))
-        (constructor alist #f)))))
-
-(define delegate-name
-  '.delegate)
+  ((record-constructor
+    (if predicate
+       (%bundle-predicate->record-type predicate)
+       <bundle>))
+   (alist-copy alist)))
 
 (define %bundle-predicate->record-type
   %predicate->record-type)
@@ -89,9 +79,9 @@ USA.
        (every (lambda (p)
                 (symbol? (car p)))
               object)))
-\f
+
 (define <bundle>
-  (new-make-record-type '<bundle> '(alist delegate)))
+  (new-make-record-type '<bundle> '(alist)))
 
 (defer-boot-action 'record-procedures
   (lambda ()
@@ -103,9 +93,6 @@ USA.
 (define bundle-alist
   (record-accessor <bundle> 'alist))
 
-(define bundle-delegate
-  (record-accessor <bundle> 'delegate))
-
 (define-print-method bundle?
   (standard-print-method
       (lambda (bundle)
@@ -123,7 +110,7 @@ USA.
          (handler)
          (map (lambda (p) `(,(car p) ,(cdr p)))
               (bundle-alist bundle))))))
-
+\f
 (define (bundle-predicate bundle)
   (guarantee bundle? bundle 'bundle-type)
   (record-predicate (record-type-descriptor bundle)))
@@ -134,25 +121,57 @@ USA.
 (define (bundle-names bundle)
   (map car (bundle-alist bundle)))
 
-(define (bundle-ref bundle operator #!optional get-default)
+(define (bundle-ref bundle name #!optional get-default)
+  (guarantee symbol? name 'bundle-ref)
   (let ((get-default
         (cond ((not get-default)
                (lambda () #f))
               ((default-object? get-default)
                (lambda ()
-                 (error "Unknown bundle operator:" operator)))
+                 (error "Unknown bundle name:" name)))
               (else
                get-default))))
-    (let ((p (assq operator (bundle-alist bundle))))
-      (cond (p (cdr p))
-           ((bundle-delegate bundle)
-            ((bundle-delegate bundle) operator get-default))
-           (else
-            (get-default))))))
-
-(define (bundle-ref/default bundle operator #!optional default)
+    (let ((p (assq name (bundle-alist bundle))))
+      (if p
+         (cdr p)
+         (get-default)))))
+
+(define (bundle-ref/default bundle name #!optional default)
   (bundle-ref bundle
-             operator
+             name
              (if (default-object? default)
                  default
-                 (lambda () default))))
\ No newline at end of file
+                 (lambda () default))))
+
+(define (bundle-map predicate procedure . bundles)
+  (bundle-map* predicate procedure bundles))
+
+(define (bundle-map* predicate procedure bundles)
+  (alist->bundle
+   predicate
+   (filter-map (lambda (name)
+                 (let ((value
+                        (apply procedure
+                               name
+                               (map (lambda (bundle)
+                                      (bundle-ref bundle name default-object))
+                                    bundles))))
+                   (and (not (default-object? value))
+                       (cons name value))))
+              (apply lset-union eq? (map bundle-names bundles)))))
+
+(define (bundle-combine predicate combiner . bundles)
+  (bundle-combine* predicate combiner bundles))
+
+(define (bundle-combine* predicate combiner bundles)
+  (bundle-map* predicate
+              (lambda (name . vals)
+                (let ((vals (remove default-object? vals)))
+                  (if (pair? (cdr vals))
+                      (combiner name vals)
+                      (car vals))))
+              bundles))
+
+(define (bundle-combiner:first name vals)
+  (declare (ignore name))
+  (car vals))
\ No newline at end of file

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index bf839e9c8898eedb8bea55d63cdb044ced0999cd..6cb7beac9e55978adf0f0c8ebe3da743f16f1886 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1953,7 +1953,11 @@ USA.
   (export ()
          alist->bundle
          bundle->alist
-          bundle-delegate
+         bundle-combine
+         bundle-combine*
+         bundle-combiner:first
+         bundle-map
+         bundle-map*
          bundle-names
          bundle-predicate
          bundle-predicate?

diff --git a/tests/runtime/test-bundle.scm b/tests/runtime/test-bundle.scm
index fe322caee2bc4d07917fe9b3acd40bffb457a29d..a625ceb8473fc00ed9cf9e74cbb5f2a15d739ec7 100644 (file)
--- a/tests/runtime/test-bundle.scm
+++ b/tests/runtime/test-bundle.scm
@@ -40,7 +40,6 @@ USA.
       (assert-eqv (bundle-ref b 'y) y)
       (assert-eqv (bundle-ref b 'z) z)
       (assert-eqv (bundle-ref b 'w #f) #f)
-      (assert-eqv (bundle-delegate b) #f)
 
       (assert-eqv (b 'x) (x))
       (assert-eqv (b 'y) (y))
@@ -145,13 +144,12 @@ USA.
 
     (let ((b1 (bundle #f x y z)))
       (let ((b2
-            (let ()
-              (define (y) 25)
-
-              (define (.delegate operator k)
-                (bundle-ref b1 operator k))
-
-              (bundle #f y .delegate))))
+            (bundle-combine #f
+                            bundle-combiner:first
+                            (let ()
+                              (define (y) 25)
+                              (bundle #f y))
+                            b1)))
 
        (assert-eqv (b1 'x) 10)
        (assert-eqv (b1 'y) 20)
@@ -178,18 +176,18 @@ USA.
       (assert-eqv (b1 'z 2) 42)
 
       (let ((b2
-            (let ()
-              (define (y n) (+ 25 n))
-
-              (define (.delegate operator k)
-                (if (eq? operator 'x)
-                    (lambda (n)
-                      (if (odd? n)
-                          (b1 'y n)
-                          (b1 'z n)))
-                    (bundle-ref b1 operator k)))
-
-              (bundle #f y .delegate))))
+            (bundle-combine #f
+                            bundle-combiner:first
+                            (let ()
+                              (define (x n)
+                                (if (odd? n)
+                                    (b1 'y n)
+                                    (b1 'z n)))
+
+                              (define (y n) (+ 25 n))
+
+                              (bundle #f x y))
+                            b1)))
 
        (assert-eqv (b2 'x 1) 21)
        (assert-eqv (b2 'x 2) 42)