Convert metadata tables to be bundles.

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index ec15d37afcec0c1d16b7ffa8592abdee69ad2b10..d2bf7ec1e15d13963a4d4c28707791b02a4cc9a2 100644 (file)
--- 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)))
-
+\f
 (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 48147a398be82b0f6fea37d926b3081c7ddbccbb..514de9b8a3efc5f3e5e19f1618317cad04258536 100644 (file)
--- 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 c6f2cda05057dae9312f793e82a641f6669a4519..94c88c1b5af20eddfa895bcf8b94f313032e5142 100644 (file)
--- 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 23b0f38643497329b4ba528fe5ed9eca30709a6a..1b60a436d1eeb77bc944bbedb98d2d00617040c8 100644 (file)
--- 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 5975e66de325ad515ba37a65b535ed8b09ed00ef..2026710674c1d370a5c88f5bd69762e4ab3288c3 100644 (file)
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -494,6 +494,9 @@ USA.
 \f
 ;;;; 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!)))
 \f
 (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!)))
 \f
 ;;;; Builder for vector-like sequences
 

diff --git a/src/runtime/hash-table.scm b/src/runtime/hash-table.scm
index 53b4243065eb9391a9e55b8acd5b17e673597fb5..aa9f1dcd26bf471db6a909b4e1dfacbcc6667b3d 100644 (file)
--- 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 4841e387d23e8278f8516c450f4eb51aee196188..a9cac454b02e7129bfcabb890ef1996a805763e8 100644 (file)
--- 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 35590d14fc25669b1ec12b4de1b665e9053a00ca..53d59cf0a71b92afb8d841e14d8699b976f4c445 100644 (file)
--- 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 0c557db515295a2cc44b08f56be8eb39d2d7a99d..f1eb126229ecb365fce96a18f60d28f0f4c520a9 100644 (file)
--- 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 6d1c8f72ba2d4031ca94233002ccf3976ddc90c7..55c09c15b40b1c30c83f09bd9b86ff78a40c816b 100644 (file)
--- 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 9ba6530c1dd68d911860551cdde2c24c929a9c86..28f914bfb0d7cd6c85fee13a7c4419469289b077 100644 (file)
--- 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)