From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 17 Jul 2019 19:55:48 +0000 (-0400)
Subject: Implement a delegation protocol for bundles.
X-Git-Tag: mit-scheme-pucked-10.1.12~7^2~9
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1afe2dabb341a1247754dbce14cb70cf81f38d54;p=mit-scheme.git

Implement a delegation protocol for bundles.
---

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index 2069278d3..fc2d4d268 100644
--- 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)))
 
 (define <bundle>
-  (make-record-type '<bundle> '(alist)))
+  (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 714d247a5..0e8bb7665 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2042,6 +2042,7 @@ USA.
   (export ()
 	  alist->bundle
 	  bundle->alist
+	  bundle-delegate
 	  bundle-names
 	  bundle-predicate
 	  bundle-predicate?
diff --git a/tests/runtime/test-bundle.scm b/tests/runtime/test-bundle.scm
index 684c31425..fe322caee 100644
--- 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