From b4a3a9e1563430a55245d90f1d19718db8031e99 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 26 Feb 2016 08:27:22 +0000
Subject: [PATCH] Implement simple metadata table abstraction.

---
 src/runtime/global.scm  | 68 +++++++++++++++++++++++++++++++++++++++++
 src/runtime/runtime.pkg |  5 +--
 2 files changed, 71 insertions(+), 2 deletions(-)

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 46b2fd975..117b8153a 100644
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -460,6 +460,74 @@ USA.
 	      (apply (cdr p) arguments))
 	    (hook-list-hooks hook-list)))
 
+;;;; 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))))))
+
 ;;;; Ephemerons
 
 ;;; The layout of an ephemeron is as follows:
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 079d1b189..566972112 100644
--- 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))
 
-- 
2.25.1