From: Chris Hanson Date: Mon, 5 Aug 2019 05:05:54 +0000 (-0700) Subject: Implement bundle delegation using a more general combinator mechanism. X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~96 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1f73148835e883fa03a53fa046afda5b7ef9c0ca;p=mit-scheme.git Implement bundle delegation using a more general combinator mechanism. --- diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm index fc2d4d268..0adbefd2f 100644 --- 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) - )))) - (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) + )) + (alist-copy alist))) (define %bundle-predicate->record-type %predicate->record-type) @@ -89,9 +79,9 @@ USA. (every (lambda (p) (symbol? (car p))) object))) - + (define - (make-record-type ' '(alist delegate))) + (make-record-type ' '(alist))) (defer-boot-action 'record-procedures (lambda () @@ -103,9 +93,6 @@ USA. (define bundle-alist (record-accessor 'alist)) -(define bundle-delegate - (record-accessor '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)))))) - + (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 1e42d19b4..9b54f51e5 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2043,7 +2043,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 fe322caee..a625ceb84 100644 --- 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)