From 2d9853a6ffb81cf6e0981cfb2a22861ae744566d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 5 Jan 2018 21:58:26 -0500 Subject: [PATCH] Rewrite the bundle machinery to separate interface and predicate. Change define-bundle-interface to require its definition names to be spelled out in the definition rather than being constructed by the macro; the result is much like define-record-type. Change the bundle lookup to use a binary search rather than a linear search, which will help when using large bundles. Although we might want to have a more flexible search strategy since it's not exposed to the end user. Add support for pretty-printing bundles similarly to records. --- src/runtime/bundle.scm | 261 +++++++++++++++++++++---------------- src/runtime/mit-macros.scm | 68 +++++----- src/runtime/runtime.pkg | 4 +- 3 files changed, 187 insertions(+), 146 deletions(-) diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm index c1fd3229d..aac9d3e75 100644 --- a/src/runtime/bundle.scm +++ b/src/runtime/bundle.scm @@ -26,158 +26,189 @@ USA. ;;;; Bundles -;;; A bundle is a set of named objects implemented as a procedure. When called, -;;; the first argument to the bundle is a symbol identifying the named object to -;;; call, and the rest of the bundle's arguments are passed to the selected -;;; procedure. If the specified named object isn't a procedure, an error is -;;; signaled. +;;; A bundle is a set of named elements. The name and metadata properties of +;;; each element are specified by an interface. Each metadata property consists +;;; of a symbol identifying the property and some objects that are the property +;;; values. While some metadata properties will be defined and used by the +;;; bundle implementation, any property can be specified and will be carried +;;; along in the interface. +;;; +;;; It is anticipated that most bundle elements will be procedures. For +;;; convenience, the bundle is itself implemented as a procedure. The first +;;; argument to the bundle is a symbol identifying the named object to call, and +;;; the rest of the bundle's arguments are passed to the selected procedure. (declare (usual-integrations)) -(define (make-bundle-interface name clauses) +(define (make-bundle-interface name elements) (guarantee symbol? name 'make-bundle-interface) - (guarantee clauses? clauses 'make-bundle-interface) + (guarantee elements? elements 'make-bundle-interface) + (let ((elements (sort-alist elements))) + (%make-bundle-interface (make-bundle-tag name) + name + (list->vector (map car elements)) + (list->vector (map (lambda (element) + (map list-copy + (cdr element))) + elements))))) + +(define (make-bundle-tag name) (letrec* ((predicate (lambda (datum) (and (bundle? datum) - (tag<= (bundle-tag datum) tag)))) + (tag<= (bundle-interface-tag (bundle-interface datum)) tag)))) (tag - (make-tag name - predicate - predicate-tagging-strategy:never - 'make-bundle-interface - (make-bim name (copy-clauses clauses))))) - (set-tag<=! tag the-bundle-tag) - predicate)) - -(define (bundle-interface? object) - (and (predicate? object) - (bim? (tag-extra (predicate->tag object))))) - -(define (bundle-interface-name interface) - (bim-name (tag-extra (predicate->tag interface)))) - -(define (bundle-interface-clauses interface) - (copy-clauses (bim-clauses (tag-extra (predicate->tag interface))))) - -(define-record-type - (make-bim name clauses) - bim? - (name bim-name) - (clauses bim-clauses)) - -(define (clauses? object) + (begin + (register-predicate! predicate name '<= bundle?) + (predicate->tag predicate)))) + tag)) + +(define (elements? object) (and (list? object) (every (lambda (p) - (or (symbol? p) - (and (pair? p) - (symbol? (car p)) - (list? (cdr p)) - (every (lambda (r) - (and (pair? r) - (symbol? (car r)) - (list? (cdr r)))) - (cdr p))))) + (and (pair? p) + (symbol? (car p)) + (list? (cdr p)) + (every (lambda (r) + (and (pair? r) + (symbol? (car r)) + (list? (cdr r)))) + (cdr p)))) object) - (let ((clause-name - (lambda (clause) - (if (symbol? clause) - clause - (car clause))))) - (let loop ((clauses object)) - (if (pair? clauses) - (and (not (any (let ((name (clause-name (car clauses)))) - (lambda (clause) - (eq? name (clause-name clause)))) - (cdr clauses))) - (loop (cdr clauses))) - #t))))) - -(define (copy-clauses clauses) - (map (lambda (clause) - (if (symbol? clause) - (list clause) - (cons (car clause) - (map list-copy (cdr clause))))) - clauses)) + (alist-has-unique-keys? object))) + +(define-record-type + (%make-bundle-interface tag name element-names element-properties) + bundle-interface? + (tag bundle-interface-tag) + (name bundle-interface-name) + (element-names %bundle-interface-element-names) + (element-properties %bundle-interface-element-properties)) + +(define (bundle-interface-predicate interface) + (tag->predicate (bundle-interface-tag interface))) + +(define (bundle-interface-element-names interface) + (vector->list (%bundle-interface-element-names interface))) + +(define (bundle-interface-element-properties interface name) + (map list-copy + (vector-ref (%bundle-interface-element-properties interface) + (element-index interface name #t)))) + +(define (element-index interface name required?) + (let ((index + (let ((v (%bundle-interface-element-names interface))) + (let loop ((start 0) (end (vector-length v))) + (and (fix:< start end) + (let* ((midpoint (fix:quotient (fix:+ start end) 2)) + (name* (vector-ref v midpoint))) + (cond ((symboltag interface))) - (check-bundle-alist alist tag) - (make-entity (lambda (self operator . args) - (apply (bundle-ref self operator) args)) - (make-bundle-metadata tag (alist-copy alist))))) + (make-entity (lambda (self operator . args) + (apply (bundle-ref self operator) args)) + (make-bundle-metadata interface + (bundle-alist->values interface alist)))) + +(define (bundle-alist->values interface alist) + (let ((n (vector-length (%bundle-interface-element-names interface)))) + (if (not (fix:= (length alist) n)) + (error "Bundle alist doesn't match its elements:" alist interface)) + (let ((values (make-vector n))) + (for-each (lambda (p) + (vector-set! values + (element-index interface (car p) #t) + (cdr p))) + alist) + values))) (define (bundle-alist? object) (and (alist? object) (every (lambda (p) (symbol? (car p))) - object))) - -(define (check-bundle-alist alist tag) - (let ((clauses (bim-clauses (tag-extra tag)))) - (if (not (lset= (lambda (a c) - (eq? (car a) (car c))) - alist - clauses)) - (error "Bundle alist doesn't match its clauses:" alist clauses)))) + object) + (alist-has-unique-keys? object))) (define-record-type - (make-bundle-metadata tag alist) + (make-bundle-metadata interface values) bundle-metadata? - (tag bundle-metadata-tag) - (alist bundle-metadata-alist)) + (interface bundle-metadata-interface) + (values bundle-metadata-values)) + +(define (bundle? object) + (and (entity? object) + (bundle-metadata? (entity-extra object)))) + +(define (bundle-interface bundle) + (bundle-metadata-interface (entity-extra bundle))) + +(define (%bundle-values bundle) + (bundle-metadata-values (entity-extra bundle))) + +(define (bundle-names bundle) + (bundle-interface-element-names (bundle-interface bundle))) + +(define (bundle-alist bundle) + (map cons + (bundle-names bundle) + (vector->list (%bundle-values bundle)))) + +(define (bundle-ref bundle operator #!optional default) + (let ((index + (element-index (bundle-interface bundle) + operator + (default-object? default)))) + (if index + (vector-ref (%bundle-values bundle) index) + default))) + +(define (alist-has-unique-keys? alist) + (or (null? alist) + (and (not (any (let ((name (caar alist))) + (lambda (p) + (eq? name (car p)))) + (cdr alist))) + (alist-has-unique-keys? (cdr alist))))) + +(define (sort-alist alist) + (sort alist + (lambda (a b) + (symboltag interface) printer)) + (hash-table-set! bundle-printers interface printer)) (set-record-type-entity-unparser-method! (standard-unparser-method (lambda (bundle) - (bim-name (tag-extra (bundle-tag bundle)))) + (bundle-interface-name (bundle-interface bundle))) (lambda (bundle port) (let ((printer - (hash-table-ref/default bundle-printers (bundle-tag bundle) #f))) + (hash-table-ref/default bundle-printers + (bundle-interface bundle) + #f))) (if printer (printer bundle port)))))) -(define (bundle? object) - (and (entity? object) - (bundle-metadata? (entity-extra object)))) - -(define (bundle-tag bundle) - (bundle-metadata-tag (entity-extra bundle))) - -(define (bundle-interface bundle) - (tag->predicate (bundle-tag bundle))) - -(define (%bundle-alist bundle) - (bundle-metadata-alist (entity-extra bundle))) +(set-record-type-entity-describer! + (lambda (bundle) + (map (lambda (name) + (list name (bundle-ref bundle name))) + (bundle-names bundle)))) -(define (bundle-alist bundle) - (alist-copy (%bundle-alist bundle))) - -(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)))) - -(define the-bundle-tag) (define bundle-printers) (add-boot-init! (lambda () - (register-predicate! bundle? 'bundle '<= entity?) - (set! the-bundle-tag (predicate->tag bundle?)) (set! bundle-printers (make-key-weak-eqv-hash-table)) (register-predicate! bundle-interface? 'bundle-interface '<= predicate?) - (register-predicate! clauses? 'interface-clauses))) \ No newline at end of file + (register-predicate! elements? 'interface-elements) + (register-predicate! bundle? 'bundle '<= entity?) + (register-predicate! bundle-alist? 'bundle-alist '<= alist?))) \ No newline at end of file diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index b2d1b874c..74bc320cb 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -769,38 +769,46 @@ USA. (er-macro-transformer (lambda (form rename compare) (declare (ignore compare)) - (syntax-check '(_ symbol * (or symbol (symbol * (symbol * datum)))) + (syntax-check '(_ identifier identifier identifier + * (or symbol (symbol * (symbol * expression)))) form) - (make-interface-helper rename (cadr form) (cddr form))))) + (make-interface-helper rename + (cadr form) + (caddr form) + (cadddr form) + (cddddr form))))) -(define (make-interface-helper rename name clauses) +(define (make-interface-helper rename interface capturer predicate elements) (rename-generated-expression rename - (let ((interface (symbol name '?))) - `(begin - ,(make-interface-definition name interface clauses) - ,(make-constructor-definition name interface - (map (lambda (clause) - (if (symbol? clause) - clause - (car clause))) - clauses)))))) - -(define (make-interface-definition name interface clauses) - `(define ,interface - (make-bundle-interface ',name ',clauses))) - -(define (make-constructor-definition name interface names) - `(define-syntax ,(symbol 'capture- name) - (sc-macro-transformer - (lambda (form use-environment) - (if (not (null? (cdr form))) - (syntax-error "Ill-formed special form:" form)) - (list 'capture-bundle - ',interface - ,@(map (lambda (name) - `(close-syntax ',name use-environment)) - names)))))) + `(begin + (define ,interface + (make-bundle-interface + ',(string->symbol (strip-angle-brackets (symbol->string interface))) + (list ,@(map (lambda (element) + (if (symbol? element) + `(list ',element) + `(list ',(car element) + ,@(map (lambda (p) + `(list ',(car p) + ,@(cdr p))) + (cdr element))))) + elements)))) + (define ,predicate + (bundle-interface-predicate ,interface)) + (define-syntax ,capturer + (sc-macro-transformer + (lambda (form use-environment) + (if (not (null? (cdr form))) + (syntax-error "Ill-formed special form:" form)) + (list 'capture-bundle + ',interface + ,@(map (lambda (element) + `(close-syntax ',(if (symbol? element) + element + (car element)) + use-environment)) + elements)))))))) (define (rename-generated-expression rename expr) (let loop ((expr expr)) @@ -827,6 +835,6 @@ USA. (define-syntax :capture-bundle (syntax-rules () - ((_ predicate name ...) - (make-bundle predicate + ((_ interface name ...) + (make-bundle interface (list (cons 'name name) ...))))) \ No newline at end of file diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index b9825a61b..3f76ab59f 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1946,8 +1946,10 @@ USA. (export () bundle-alist bundle-interface - bundle-interface-clauses + bundle-interface-element-names + bundle-interface-element-properties bundle-interface-name + bundle-interface-predicate bundle-interface? bundle-names bundle-ref -- 2.25.1