Implement a delegation protocol for bundles.

Manual cherry-pick of 1afe2dabb341a1247754dbce14cb70cf81f38d54.

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index d6a436237fd17907f7a7c4c6def641db6ad1edc1..c6cc691437e4ec1f1892f77e6fb8018a7abcd1fb 100644 (file)
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -57,11 +57,21 @@ USA.
 
 (define (alist->bundle predicate alist)
   (guarantee %bundle-alist? alist 'alist->bundle)
-  ((record-constructor
-    (if predicate
-       (%bundle-predicate->record-type predicate)
-       <bundle>))
-   (alist-copy alist)))
+  (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)
 
 (define %bundle-predicate->record-type
   %predicate->record-type)
@@ -81,7 +91,7 @@ USA.
               object)))
 \f
 (define <bundle>
-  (new-make-record-type '<bundle> '(alist)))
+  (new-make-record-type '<bundle> '(alist delegate)))
 
 (defer-boot-action 'record-procedures
   (lambda ()
@@ -93,6 +103,9 @@ USA.
 (define bundle-alist
   (record-accessor <bundle> 'alist))
 
+(define bundle-delegate
+  (record-accessor <bundle> 'delegate))
+
 (define-print-method bundle?
   (standard-print-method
       (lambda (bundle)
@@ -121,11 +134,25 @@ USA.
 (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
+(define (bundle-ref bundle operator #!optional get-default)
+  (let ((get-default
+        (cond ((not get-default)
+               (lambda () #f))
+              ((default-object? get-default)
+               (lambda ()
+                 (error "Unknown bundle operator:" operator)))
+              (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)
+  (bundle-ref bundle
+             operator
+             (if (default-object? default)
+                 default
+                 (lambda () default))))
\ No newline at end of file

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 7830e68afe0f85a51a1d8286afb64c8653d9ddbd..1189792ef434871834af0ec5ec8720328c6efb32 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1952,10 +1952,12 @@ USA.
   (export ()
          alist->bundle
          bundle->alist
+          bundle-delegate
          bundle-names
          bundle-predicate
          bundle-predicate?
          bundle-ref
+         bundle-ref/default
          bundle?
          make-bundle-predicate))
 

diff --git a/tests/runtime/test-bundle.scm b/tests/runtime/test-bundle.scm
index 684c314255e63488fdd8fe8252b8fd3c7d0dfde0..fe322caee2bc4d07917fe9b3acd40bffb457a29d 100644 (file)
--- a/tests/runtime/test-bundle.scm
+++ b/tests/runtime/test-bundle.scm
@@ -40,6 +40,7 @@ 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))
@@ -134,4 +135,65 @@ USA.
     (assert-eqv (foo 'get 'x) 55)
     (assert-eqv (foo 'get 'x 33) 55)
     (assert-equal (foo 'get-alist) '((x . 55)))
-    ))
\ No newline at end of file
+    ))
+
+(define-test 'delegation
+  (lambda ()
+    (define (x) 10)
+    (define (y) 20)
+    (define (z) 40)
+
+    (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))))
+
+       (assert-eqv (b1 'x) 10)
+       (assert-eqv (b1 'y) 20)
+       (assert-eqv (b1 'z) 40)
+       (assert-error (lambda () (b1 'foo)))
+
+       (assert-eqv (b2 'x) 10)
+       (assert-eqv (b2 'y) 25)
+       (assert-eqv (b2 'z) 40)
+       (assert-error (lambda () (b2 'foo)))))))
+
+(define-test 'lazy-delegation
+  (lambda ()
+    (define (x n) (+ 10 n))
+    (define (y n) (+ 20 n))
+    (define (z n) (+ 40 n))
+
+    (let ((b1 (bundle #f x y z)))
+      (assert-eqv (b1 'x 1) 11)
+      (assert-eqv (b1 'x 2) 12)
+      (assert-eqv (b1 'y 1) 21)
+      (assert-eqv (b1 'y 2) 22)
+      (assert-eqv (b1 'z 1) 41)
+      (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))))
+
+       (assert-eqv (b2 'x 1) 21)
+       (assert-eqv (b2 'x 2) 42)
+       (assert-eqv (b2 'y 1) 26)
+       (assert-eqv (b2 'y 2) 27)
+       (assert-eqv (b2 'z 1) 41)
+       (assert-eqv (b2 'z 2) 42)))))
\ No newline at end of file