From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 6 Jan 2017 03:18:44 +0000 (-0800)
Subject: Change tagged-object to be tagged with a predicate.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~217
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cf394560e572d6aeb2d6cb318ac993071aa4a250;p=mit-scheme.git

Change tagged-object to be tagged with a predicate.
---

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 67cd24b2e..ff466d02f 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -449,9 +449,9 @@ USA.
    (RUNTIME STREAM)
    (RUNTIME 2D-PROPERTY)
    (RUNTIME HASH-TABLE)
-   ((RUNTIME TAGGING) INITIALIZE-UNPARSER!)
    (RUNTIME PREDICATE-METADATA)
    (RUNTIME PREDICATE-LATTICE)
+   (RUNTIME TAGGING)
    (RUNTIME HASH)
    (RUNTIME DYNAMIC)
    (RUNTIME REGULAR-SEXPRESSION)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index f602bf218..467152d5a 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3597,14 +3597,16 @@ USA.
   (parent (runtime))
   (export ()
 	  guarantee-tagged-object
-	  make-tagged-object
 	  set-tagged-object-unparser-method!
+	  tag-object
 	  tagged-object-datum
-	  tagged-object-tag
+	  tagged-object-predicate
 	  tagged-object?)
+  (export (runtime)
+	  tagged-object-tag)
   (export (runtime unparser)
 	  get-tagged-object-unparser-method)
-  (initialization (initialize-unparser!)))
+  (initialization (initialize-package!)))
 
 (define-package (runtime reference-trap)
   (files "urtrap")
diff --git a/src/runtime/tagging.scm b/src/runtime/tagging.scm
index 868b181a1..5cd0a05ab 100644
--- a/src/runtime/tagging.scm
+++ b/src/runtime/tagging.scm
@@ -35,21 +35,23 @@ USA.
 (define (tagged-object? object)
   (fix:= (object-type object) tagged-object-type))
 
-(define-guarantee tagged-object "tagged object")
+(define (tag-object predicate datum)
+  (system-pair-cons tagged-object-type (predicate->tag predicate) datum))
 
-(define (make-tagged-object tag datum)
-  (system-pair-cons tagged-object-type tag datum))
+(define (tagged-object-predicate object)
+  (tag->predicate (tagged-object-tag object)))
 
 (define (tagged-object-tag object)
-  (guarantee-tagged-object object 'tagged-object-tag)
+  (guarantee tagged-object? object 'tagged-object-tag)
   (system-pair-car object))
 
 (define (tagged-object-datum object)
-  (guarantee-tagged-object object 'tagged-object-datum)
+  (guarantee tagged-object? object 'tagged-object-datum)
   (system-pair-cdr object))
 
 (define unparser-methods)
-(define (initialize-unparser!)
+(define (initialize-package!)
+  (register-predicate! tagged-object? 'tagged-object)
   (set! unparser-methods (make-key-weak-eqv-hash-table))
   unspecific)