From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 29 Apr 2018 22:57:51 +0000 (-0700)
Subject: Convert metadata tables to be bundles.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~92
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=10f0f3f9d0b5257c69a7c03860063058d7b62fc8;p=mit-scheme.git

Convert metadata tables to be bundles.
---

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index ec15d37af..d2bf7ec1e 100644
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -65,16 +65,24 @@ USA.
   (record-predicate type))
 
 (define (alist->bundle type alist)
-  (guarantee bundle-type? type 'alist->bundle)
   (guarantee %bundle-alist? alist 'alist->bundle)
   ((record-constructor type) (alist-copy alist)))
 
+(defer-boot-action 'predicate-relations
+  (lambda ()
+    (set! alist->bundle
+	  (named-lambda (alist->bundle type alist)
+	    (guarantee bundle-type? type 'alist->bundle)
+	    (guarantee %bundle-alist? alist 'alist->bundle)
+	    ((record-constructor type) (alist-copy alist))))
+    unspecific))
+
 (define (%bundle-alist? object)
   (and (alist? object)
        (every (lambda (p)
                 (symbol? (car p)))
               object)))
-
+
 (define-record-type <bundle>
     (%unused% alist) ;change to #f after 9.3 release
     bundle?
diff --git a/src/runtime/char.scm b/src/runtime/char.scm
index 48147a398..514de9b8a 100644
--- a/src/runtime/char.scm
+++ b/src/runtime/char.scm
@@ -684,8 +684,8 @@ USA.
 (add-boot-init!
  (lambda ()
    (let ((table (make-alist-metadata-table)))
-     (set! get-char-codec (table 'get))
-     (set! set-char-codec! (table 'put!))
+     (set! get-char-codec (bundle-ref table 'get))
+     (set! set-char-codec! (bundle-ref table 'put!))
      unspecific)))
 
 (define (define-char-codec name codec)
diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm
index c6f2cda05..94c88c1b5 100644
--- a/src/runtime/compound-predicate.scm
+++ b/src/runtime/compound-predicate.scm
@@ -122,8 +122,8 @@ USA.
 (add-boot-init!
  (lambda ()
    (let ((table (make-alist-metadata-table)))
-     (set! compound-operator-builder (table 'get))
-     (set! define-compound-operator (table 'put!))
+     (set! compound-operator-builder (bundle-ref table 'get))
+     (set! define-compound-operator (bundle-ref table 'put!))
      unspecific)))
 
 (add-boot-init!
diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm
index 23b0f3864..1b60a436d 100644
--- a/src/runtime/dynamic.scm
+++ b/src/runtime/dynamic.scm
@@ -36,20 +36,21 @@ USA.
 (define get-metadata-alist)
 
 (define (use-metadata-implementation! implementation)
-  (set! parameter? (implementation 'has?))
-  (set! parameter-metadata (implementation 'get))
-  (set! set-parameter-metadata! (implementation 'put!))
-  (set! get-metadata-alist (implementation 'get-alist))
+  (set! parameter? (bundle-ref implementation 'has?))
+  (set! parameter-metadata (bundle-ref implementation 'get))
+  (set! set-parameter-metadata! (bundle-ref implementation 'put!))
+  (set! get-metadata-alist (bundle-ref implementation 'get-alist))
   unspecific)
 
 ;; Use alist for cold-load.
 (use-metadata-implementation! (make-alist-metadata-table))
 
 ;; Later move metadata to hash table.
-(define (initialize-package!)
-  (let ((implementation (make-hashed-metadata-table)))
-    ((implementation 'put-alist!) (get-metadata-alist))
-    (use-metadata-implementation! implementation)))
+(add-boot-init!
+ (lambda ()
+   (let ((implementation (make-hashed-metadata-table)))
+     (implementation 'put-alist! (get-metadata-alist))
+     (use-metadata-implementation! implementation))))
 
 (define-guarantee parameter "parameter")
 
diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 5975e66de..202671067 100644
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -494,6 +494,9 @@ USA.
 
 ;;;; Metadata tables
 
+(define <metadata-table>
+  (make-bundle-type 'metadata-table))
+
 (define (make-alist-metadata-table)
   (let ((alist '()))
 
@@ -540,17 +543,8 @@ USA.
 		  (put! (car p) (cdr p)))
 		alist*))
 
-    (lambda (operator)
-      (case operator
-	((has?) has?)
-	((get) get)
-	((put!) put!)
-	((intern!) intern!)
-	((delete!) delete!)
-	((get-alist) get-alist)
-	((put-alist!) put-alist!)
-	((get-if-available) get)
-	(else (error "Unknown operator:" operator))))))
+    (bundle <metadata-table>
+	    has? get put! intern! delete! get-alist put-alist!)))
 
 (define (make-hashed-metadata-table)
   (let ((table (make-key-weak-eqv-hash-table)))
@@ -580,17 +574,8 @@ USA.
 		  (put! (car p) (cdr p)))
 		alist*))
 
-    (lambda (operator)
-      (case operator
-	((has?) has?)
-	((get) get)
-	((put!) put!)
-	((intern!) intern!)
-	((delete!) delete!)
-	((get-alist) get-alist)
-	((put-alist!) put-alist!)
-	((get-if-available) get)
-	(else (error "Unknown operator:" operator))))))
+    (bundle <metadata-table>
+	    has? get put! intern! delete! get-alist put-alist!)))
 
 ;;;; Builder for vector-like sequences
 
diff --git a/src/runtime/hash-table.scm b/src/runtime/hash-table.scm
index 53b424306..aa9f1dcd2 100644
--- a/src/runtime/hash-table.scm
+++ b/src/runtime/hash-table.scm
@@ -1387,9 +1387,9 @@ USA.
 (add-boot-init!
  (lambda ()
    (let ((table (make-hashed-metadata-table)))
-     (set! equality-predicate? (table 'has?))
-     (set! %equality-predicate-properties (table 'get))
-     (set! %set-equality-predicate-properties! (table 'put!)))
+     (set! equality-predicate? (bundle-ref table 'has?))
+     (set! %equality-predicate-properties (bundle-ref table 'get))
+     (set! %set-equality-predicate-properties! (bundle-ref table 'put!)))
    (set-equality-predicate-properties! eq? hash-by-identity #t)
    (set-equality-predicate-properties! eqv? hash-by-eqv #t)
    (set-equality-predicate-properties! equal? hash-by-equal #t)
diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm
index 4841e387d..a9cac454b 100644
--- a/src/runtime/host-adapter.scm
+++ b/src/runtime/host-adapter.scm
@@ -81,6 +81,14 @@ USA.
 			(->environment '(runtime hash-table))
 			'hash-table-constructor))
 
+    (if (unbound? env 'bundle)
+	(eval '(define-syntax bundle
+		 (syntax-rules ()
+		   ((_ predicate name ...)
+		    (alist->bundle predicate
+				   (list (cons 'name name) ...)))))
+	      env))
+
     (for-each (lambda (old-name)
 		(provide-rename env old-name (symbol 'scode- old-name)))
 	      '(access-environment
diff --git a/src/runtime/predicate.scm b/src/runtime/predicate.scm
index 35590d14f..53d59cf0a 100644
--- a/src/runtime/predicate.scm
+++ b/src/runtime/predicate.scm
@@ -112,9 +112,9 @@ USA.
 (add-boot-init!
  (lambda ()
    (let ((table (make-hashed-metadata-table)))
-     (set! predicate? (table 'has?))
-     (set! get-predicate-tag (table 'get))
-     (set! set-predicate-tag! (table 'put!)))
+     (set! predicate? (bundle-ref table 'has?))
+     (set! get-predicate-tag (bundle-ref table 'get))
+     (set! set-predicate-tag! (bundle-ref table 'put!)))
    (set! predicate->dispatch-tag
 	 (named-lambda (predicate->dispatch-tag predicate)
 	   (let ((tag (get-predicate-tag predicate #f)))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 0c557db51..f1eb12622 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4359,8 +4359,7 @@ USA.
 	  make-general-parameter
 	  make-settable-parameter
 	  make-unsettable-parameter
-	  parameterize*)
-  (initialization (initialize-package!)))
+	  parameterize*))
 
 (define-package (runtime stream)
   (files "stream")
diff --git a/src/runtime/textual-port.scm b/src/runtime/textual-port.scm
index 6d1c8f72b..55c09c15b 100644
--- a/src/runtime/textual-port.scm
+++ b/src/runtime/textual-port.scm
@@ -507,22 +507,22 @@ USA.
 
 (define (port-property port name #!optional default-value)
   (guarantee symbol? name 'port-property)
-  (((port-metadata port) 'get) name default-value))
+  ((port-metadata port) 'get name default-value))
 
 (define (set-port-property! port name value)
   (guarantee symbol? name 'set-port-property!)
-  (((port-metadata port) 'put!) name value))
+  ((port-metadata port) 'put! name value))
 
 (define (intern-port-property! port name get-value)
   (guarantee symbol? name 'intern-port-property!)
-  (((port-metadata port) 'intern!) name get-value))
+  ((port-metadata port) 'intern! name get-value))
 
 (define (remove-port-property! port name)
   (guarantee symbol? name 'remove-port-property!)
-  (((port-metadata port) 'delete!) name))
+  ((port-metadata port) 'delete! name))
 
 (define (port-properties port)
-  (alist-copy (((port-metadata port) 'get-alist))))
+  (alist-copy ((port-metadata port) 'get-alist)))
 
 (define (transcribe-char char port)
   (let ((tport (textual-port-transcript port)))
diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm
index 9ba6530c1..28f914bfb 100644
--- a/tests/unit-testing.scm
+++ b/tests/unit-testing.scm
@@ -454,9 +454,9 @@ USA.
 (define comparator-metadata)
 (define set-comparator-metadata!)
 (let ((table (make-hashed-metadata-table)))
-  (set! comparator? (table 'has?))
-  (set! comparator-metadata (table 'get))
-  (set! set-comparator-metadata! (table 'put!))
+  (set! comparator? (bundle-ref table 'has?))
+  (set! comparator-metadata (bundle-ref table 'get))
+  (set! set-comparator-metadata! (bundle-ref table 'put!))
   unspecific)
 
 (define-for-tests (define-comparator comparator name)