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