From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 19 Jan 2018 02:26:32 +0000 (-0800)
Subject: Refactor bundle interfaces to be dispatch tags.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~340
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a28db0810942bf2962e5abb0657199e66a108beb;p=mit-scheme.git

Refactor bundle interfaces to be dispatch tags.

Also add some unit tests.
---

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index a78024dea..3db13b260 100644
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -43,26 +43,20 @@ USA.
 (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)
@@ -80,16 +74,21 @@ USA.
        (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)))
@@ -113,7 +112,12 @@ USA.
 	(error "Unknown element name:" name interface))
     index))
 
+(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))
@@ -146,13 +150,9 @@ USA.
   (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)))
@@ -190,26 +190,14 @@ USA.
 	(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
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 1b4d2bbbd..50b0f1a86 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1928,13 +1928,10 @@ USA.
 	  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))
 
diff --git a/tests/check.scm b/tests/check.scm
index 2368ad63b..fcc82249f 100644
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -50,6 +50,7 @@ USA.
     "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))
diff --git a/tests/runtime/test-bundle.scm b/tests/runtime/test-bundle.scm
new file mode 100644
index 000000000..a13e81872
--- /dev/null
+++ b/tests/runtime/test-bundle.scm
@@ -0,0 +1,134 @@
+#| -*-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))
+
+(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