From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 16 Jan 2017 08:22:43 +0000 (-0800)
Subject: Generalize metadata tables to support intern!.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~127
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=81e63f226d7e46348fbf694642879a9250869f4f;p=mit-scheme.git

Generalize metadata tables to support intern!.

Also generalize the get method to accept an optional value.
---

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 256ce3453..64b0b5458 100644
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -493,17 +493,14 @@ USA.
     (define (has? key)
       (if (assv key alist) #t #f))
 
-    (define (get key)
-      (let ((metadata (get-if-available key (default-object))))
-	(if (default-object? metadata)
-	    (error "Object has no associated metadata:" key))
-	metadata))
-
-    (define (get-if-available key default-value)
+    (define (get key #!optional default-value)
       (let ((p (assv key alist)))
 	(if p
 	    (cdr p)
-	    default-value)))
+	    (begin
+	      (if (default-object? default-value)
+		  (error "Object has no associated metadata:" key))
+	      default-value))))
 
     (define (put! key metadata)
       (let ((p (assv key alist)))
@@ -513,6 +510,14 @@ USA.
 	      (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)
@@ -532,11 +537,12 @@ USA.
       (case operator
 	((has?) has?)
 	((get) get)
-	((get-if-available) get-if-available)
 	((put!) put!)
+	((intern!) intern!)
 	((delete!) delete!)
 	((get-alist) get-alist)
 	((put-alist!) put-alist!)
+	((get-if-available) get)
 	(else (error "Unknown operator:" operator))))))
 
 (define (make-hashed-metadata-table)
@@ -545,18 +551,17 @@ USA.
     (define (has? key)
       (hash-table-exists? table key))
 
-    (define (get key)
-      (let ((metadata (get-if-available key (default-object))))
-	(if (default-object? metadata)
-	    (error "Object has no associated metadata:" key))
-	metadata))
-
-    (define (get-if-available key default-value)
-      (hash-table-ref/default table key default-value))
+    (define (get key #!optional default-value)
+      (if (default-object? default-value)
+	  (hash-table-ref table key)
+	  (hash-table-ref/default table key default-value)))
 
     (define (put! key metadata)
       (hash-table-set! table key metadata))
 
+    (define (intern! key get-value)
+      (hash-table-intern! table key get-value))
+
     (define (delete! key)
       (hash-table-delete! table key))
 
@@ -572,11 +577,12 @@ USA.
       (case operator
 	((has?) has?)
 	((get) get)
-	((get-if-available) get-if-available)
 	((put!) put!)
+	((intern!) intern!)
 	((delete!) delete!)
 	((get-alist) get-alist)
 	((put-alist!) put-alist!)
+	((get-if-available) get)
 	(else (error "Unknown operator:" operator))))))
 
 ;;;; Ephemerons