Implement simple metadata table abstraction.

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 46b2fd975b7d2fa874f8c12bc5f6e452560a10f0..117b8153a944c3dc0d9db4f7518eb7d05c67f2c9 100644 (file)
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -460,6 +460,74 @@ USA.
              (apply (cdr p) arguments))
            (hook-list-hooks hook-list)))
 \f
+;;;; Metadata tables
+
+(define (make-alist-metadata-table)
+  (let ((alist '()))
+
+    (define (has? key)
+      (if (assv key alist) #t #f))
+
+    (define (get key)
+      (let ((p (assv key alist)))
+       (if (not p)
+           (error "Unregistered key:" key))
+       (cdr p)))
+
+    (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 (get-alist)
+      alist)
+
+    (define (put-alist! alist*)
+      (for-each (lambda (p)
+                 (put! (car p) (cdr p)))
+               alist*))
+
+    (lambda (operator)
+      (case operator
+       ((has?) has?)
+       ((get) get)
+       ((put!) put!)
+       ((get-alist) get-alist)
+       ((put-alist!) put-alist!)
+       (else (error "Unknown operator:" operator))))))
+
+(define (make-hashed-metadata-table)
+  (let ((table (make-key-weak-eqv-hash-table)))
+
+    (define (has? key)
+      (hash-table-exists? table key))
+
+    (define (get key)
+      (hash-table-ref table key))
+
+    (define (put! key metadata)
+      (hash-table-set! table key metadata))
+
+    (define (get-alist)
+      (hash-table->alist table))
+
+    (define (put-alist! alist*)
+      (for-each (lambda (p)
+                 (put! (car p) (cdr p)))
+               alist*))
+
+    (lambda (operator)
+      (case operator
+       ((has?) has?)
+       ((get) get)
+       ((put!) put!)
+       ((get-alist) get-alist)
+       ((put-alist!) put-alist!)
+       (else (error "Unknown operator:" operator))))))
+\f
 ;;;; Ephemerons
 
 ;;; The layout of an ephemeron is as follows:

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 079d1b189fc2a3c5d1731e5a58d6bcaf69aea83b..56697211231a03b39b9ed804fb747a7ba8471e8d 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -481,8 +481,10 @@ USA.
          limit-interrupts!
          link-variables
          local-assignment
+         make-alist-metadata-table
          make-cell
          make-ephemeron
+         make-hashed-metadata-table
          make-hook-list
          make-non-pointer-object
          non-pointer-type-code?
@@ -4908,8 +4910,7 @@ USA.
          (letrec* :letrec*)
          (local-declare :local-declare)
          (quasiquote :quasiquote)
-         (receive :receive)
-         supported-srfi-features)
+         (receive :receive))
   (export (runtime)
          parse-define-form))