Also add some unit tests.
(define (make-bundle-interface name elements)
(guarantee symbol? name '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)
- (dispatch-tag<= (bundle-interface-tag (bundle-interface datum))
- tag))))
+ (lambda (object)
+ (and (bundle? object)
+ (dispatch-tag<= (bundle-interface object) tag))))
(tag
- (begin
- (register-predicate! predicate name '<= bundle?)
- (predicate->dispatch-tag predicate))))
+ (let ((elements (sort-alist elements)))
+ (%make-bundle-interface name
+ predicate
+ (list->vector (map car elements))
+ (list->vector (map (lambda (element)
+ (map list-copy
+ (cdr element)))
+ elements))))))
tag))
(define (elements? object)
(alist-has-unique-keys? object)))
(register-predicate! elements? 'interface-elements)
-(define-record-type <bundle-interface>
- (%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?)
+(define %make-bundle-interface)
+(add-boot-init!
+ (lambda ()
+ (let ((metatag (make-dispatch-metatag 'bundle-interface)))
+ (set! bundle-interface? (dispatch-tag->predicate metatag))
+ (set! %make-bundle-interface
+ (dispatch-metatag-constructor metatag 'make-bundle-interface))
+ unspecific)))
-(define (bundle-interface-predicate interface)
- (dispatch-tag->predicate (bundle-interface-tag interface)))
+(define-integrable (%bundle-interface-element-names interface)
+ (dispatch-tag-extra interface 0))
+
+(define-integrable (%bundle-interface-element-properties interface)
+ (dispatch-tag-extra interface 1))
(define (bundle-interface-element-names interface)
(vector->list (%bundle-interface-element-names interface)))
(error "Unknown element name:" name interface))
index))
\f
+(define (bundle? object)
+ (and (entity? object)
+ (bundle-metadata? (entity-extra object))))
+
(define (make-bundle interface alist)
+ (guarantee bundle-interface? interface 'make-bundle)
(guarantee bundle-alist? alist 'make-bundle)
(make-entity (lambda (self operator . args)
(apply (bundle-ref self operator) args))
(interface bundle-metadata-interface)
(values bundle-metadata-values))
-(define (bundle? object)
- (and (entity? object)
- (bundle-metadata? (entity-extra object))))
-
-(defer-boot-action 'predicate-registrations
- (lambda ()
- (register-predicate! bundle? 'bundle '<= entity?)))
+(add-boot-init!
+ (lambda ()
+ (register-predicate! bundle? 'bundle '<= entity?)))
(define (bundle-interface bundle)
(bundle-metadata-interface (entity-extra bundle)))
(lambda (a b)
(symbol<? (car a) (car b)))))
-(define (define-bundle-printer interface printer)
- (hash-table-set! bundle-printers interface printer))
-
(define-unparser-method bundle?
(standard-unparser-method
(lambda (bundle)
- (bundle-interface-name (bundle-interface bundle)))
- (lambda (bundle port)
- (let ((printer
- (hash-table-ref/default bundle-printers
- (bundle-interface bundle)
- #f)))
- (if printer
- (printer bundle port))))))
+ (dispatch-tag-name (bundle-interface bundle)))
+ #f))
(define-pp-describer bundle?
(lambda (bundle)
(map (lambda (name)
(list name (bundle-ref bundle name)))
- (bundle-names bundle))))
-
-(define-deferred bundle-printers
- (make-key-weak-eqv-hash-table))
\ No newline at end of file
+ (bundle-names bundle))))
\ No newline at end of file
bundle-interface
bundle-interface-element-names
bundle-interface-element-properties
- bundle-interface-name
- bundle-interface-predicate
bundle-interface?
bundle-names
bundle-ref
bundle?
- define-bundle-printer
make-bundle
make-bundle-interface))
"runtime/test-arith"
"runtime/test-binary-port"
"runtime/test-blowfish"
+ "runtime/test-bundle"
"runtime/test-bytevector"
("runtime/test-char" (runtime))
("runtime/test-char-set" (runtime character-set))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Tests for bundles
+
+(declare (usual-integrations))
+\f
+(define-test 'simple
+ (lambda ()
+ (define-bundle-interface <foo> capture-foo foo? a b c)
+
+ (assert-true (bundle-interface? <foo>))
+ (assert-equal (bundle-interface-element-names <foo>)
+ '(a b c))
+ (for-each (lambda (name)
+ (assert-equal (bundle-interface-element-properties <foo> name)
+ '()))
+ (bundle-interface-element-names <foo>))
+
+ (define foo
+ (let ((a 0)
+ (b 1)
+ (c 3))
+ (capture-foo)))
+
+ (assert-true (foo? foo))
+ (assert-eqv (bundle-ref foo 'a) 0)
+ (assert-eqv (bundle-ref foo 'b) 1)
+ (assert-eqv (bundle-ref foo 'c) 3)
+ (assert-eqv (bundle-ref foo 'd #f) #f)
+ (assert-error (lambda () (bundle-ref foo 'd)))))
+
+(define-test 'metadata-table
+ (lambda ()
+
+ (define-bundle-interface <metadata-table>
+ capture-metadata-table
+ metadata-table?
+ has?
+ get
+ put!
+ intern!
+ delete!
+ get-alist
+ put-alist!)
+
+ (define foo
+ (let ((alist '()))
+
+ (define (has? key)
+ (if (assv key alist) #t #f))
+
+ (define (get key #!optional default-value)
+ (let ((p (assv key alist)))
+ (if p
+ (cdr p)
+ (begin
+ (if (default-object? default-value)
+ (error "Object has no associated metadata:" key))
+ default-value))))
+
+ (define (put! key metadata)
+ (let ((p (assv key alist)))
+ (if p
+ (set-cdr! p metadata)
+ (begin
+ (set! alist (cons (cons key metadata) alist))
+ unspecific))))
+
+ (define (intern! key get-value)
+ (let ((p (assv key alist)))
+ (if p
+ (cdr p)
+ (let ((value (get-value)))
+ (set! alist (cons (cons key value) alist))
+ value))))
+
+ (define (delete! key)
+ (set! alist
+ (remove! (lambda (p)
+ (eqv? (car p) key))
+ alist))
+ unspecific)
+
+ (define (get-alist)
+ alist)
+
+ (define (put-alist! alist*)
+ (for-each (lambda (p)
+ (put! (car p) (cdr p)))
+ alist*))
+
+ (capture-metadata-table)))
+
+ (assert-true (metadata-table? foo))
+
+ (assert-false (foo 'has? 'x))
+ (assert-false (foo 'has? 'y))
+ (assert-error (lambda () (foo 'get 'x)))
+ (assert-error (lambda () (foo 'get 'y)))
+ (assert-eqv (foo 'get 'x 33) 33)
+ (assert-eqv (foo 'get 'y 44) 44)
+ (assert-equal (foo 'get-alist) '())
+
+ (foo 'put! 'x 55)
+ (assert-true (foo 'has? 'x))
+ (assert-false (foo 'has? 'y))
+ (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
projects / mit-scheme.git / commitdiff