From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 11 Jan 2018 07:15:31 +0000 (-0800)
Subject: Simplify predicate-tagging so that it provides only the essentials.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~379
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=af820bd4bbfa6d5a5cbbaa7ac40eeb0debfbb87b;p=mit-scheme.git

Simplify predicate-tagging so that it provides only the essentials.

This too is subject to change.  The tagging strategy idea needs to be revisited
in a larger context since it doesn't account complex structures like records.
---

diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm
index ac772f8c7..be76f2e4b 100644
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -33,44 +33,36 @@ USA.
   (object-type? (ucode-type tagged-object) object))
 (register-predicate! tagged-object? 'tagged-object)
 
-(define (object-tagger predicate)
-  (let ((tag (predicate->tag predicate)))
-    (lambda (datum)
-      (make-tagged-object tag datum))))
-
-(define (tag-object predicate datum)
-  (make-tagged-object (predicate->tag predicate) datum))
+(define-integrable (%make-tagged-object tag datum)
+  (system-pair-cons (ucode-type tagged-object) tag datum))
 
-(define (tagged-object-predicate object)
-  (tag->predicate (tagged-object-tag object)))
+(define-integrable (%tagged-object-tag object)
+  (system-pair-car object))
 
-(define-integrable (make-tagged-object tag datum)
-  (system-pair-cons (ucode-type tagged-object) tag datum))
+(define-integrable (%tagged-object-datum object)
+  (system-pair-cdr object))
 
 (define (tagged-object-tag object)
   (guarantee tagged-object? object 'tagged-object-tag)
-  (system-pair-car object))
+  (%tagged-object-tag object))
 
 (define (tagged-object-datum object)
   (guarantee tagged-object? object 'tagged-object-datum)
-  (system-pair-cdr object))
+  (%tagged-object-datum object))
 
-(define unparser-methods)
-(add-boot-init!
- (lambda ()
-   (set! unparser-methods (make-key-weak-eqv-hash-table))
-   unspecific))
+(define (object->predicate object)
+  (tag->predicate (object->tag object)))
 
-(define (get-tagged-object-unparser-method object)
-  (hash-table-ref/default unparser-methods (tagged-object-tag object) #f))
+(define (object->tag object)
+  (let ((code (object-type object)))
+    (or (vector-ref primitive-tags code)
+	((vector-ref primitive-tag-methods code) object)
+	(error "Unknown type code:" code))))
 
-(define (set-tagged-object-unparser-method! tag unparser)
-  (if unparser
-      (begin
-	(guarantee unparser-method? unparser
-		   'set-tagged-object-unparser-method!)
-	(hash-table-set! unparser-methods tag unparser))
-      (hash-table-delete! unparser-methods tag)))
+(define (object->datum object)
+  (if (tagged-object? object)
+      (%tagged-object-datum object)
+      object))
 
 ;;;; Tagging strategies
 
@@ -94,18 +86,18 @@ USA.
 
   (define (predicate object)
     (and (tagged-object? object)
-         (tag<= (tagged-object-tag object) tag)
-         (datum-test (tagged-object-datum object))))
+         (tag<= (%tagged-object-tag object) tag)
+         (datum-test (%tagged-object-datum object))))
 
   (define (tagger datum #!optional tagger-name)
     (if (not (datum-test datum))
 	(error:wrong-type-argument datum (string "datum for " name)
 				   tagger-name))
-    (make-tagged-object tag datum))
+    (%make-tagged-object tag datum))
 
   (define (untagger object #!optional untagger-name)
     (guarantee predicate object untagger-name)
-    (tagged-object-datum object))
+    (%tagged-object-datum object))
 
   (define tag
     (make-tag predicate tagger untagger))
@@ -120,8 +112,8 @@ USA.
 
   (define (tagged-object-test object)
     (and (tagged-object? object)
-	 (tag<= (tagged-object-tag object) tag)
-	 (datum-test (tagged-object-datum object))))
+	 (tag<= (%tagged-object-tag object) tag)
+	 (datum-test (%tagged-object-datum object))))
 
   (define (tagger datum #!optional tagger-name)
     (if (not (datum-test datum))
@@ -129,10 +121,10 @@ USA.
 				   tagger-name))
     (if (tag<= (object->tag datum) tag)
         datum
-        (make-tagged-object tag datum)))
+        (%make-tagged-object tag datum)))
 
   (define (untagger object #!optional untagger-name)
-    (cond ((tagged-object-test object) (tagged-object-datum object))
+    (cond ((tagged-object-test object) (%tagged-object-datum object))
 	  ((datum-test object) object)
 	  (else (error:not-a predicate object untagger-name))))
 
@@ -141,19 +133,6 @@ USA.
 
   tag)
 
-(define (object->predicate object)
-  (tag->predicate (object->tag object)))
-
-(define (object->tag object)
-  (let ((code (object-type object)))
-    (or (vector-ref primitive-tags code)
-	((vector-ref primitive-tag-methods code) object)
-	(error "Unknown type code:" code))))
-
-(define (object->datum object)
-  (cond ((tagged-object? object) (system-pair-cdr object))
-        (else object)))
-
 (define primitive-tags)
 (define primitive-tag-methods)
 (add-boot-init!
@@ -205,7 +184,7 @@ USA.
        (vector-set! primitive-tag-methods type-code method)))
 
    (define-primitive-predicate-method 'tagged-object
-     system-pair-car)
+     %tagged-object-tag)
 
    (define-primitive-predicate-method 'constant
      (let* ((constant-tags
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 92ad4f9c4..f473420c4 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1908,18 +1908,11 @@ USA.
 	  predicate-tagging-strategy:never
 	  predicate-tagging-strategy:optional
 	  object->datum
-	  object->predicate
-	  object-tagger
-	  set-tagged-object-unparser-method!
-	  tag-object
-	  tagged-object-datum
-	  tagged-object-predicate
-	  tagged-object?)
+	  object->predicate)
   (export (runtime)
 	  object->tag
-	  tagged-object-tag)
-  (export (runtime unparser)
-	  get-tagged-object-unparser-method))
+	  tagged-object-datum
+	  tagged-object-tag))
 
 (define-package (runtime predicate-dispatch)
   (files "predicate-dispatch")
diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 39783ab9d..a1aec9ef3 100644
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -284,9 +284,6 @@ USA.
 
 (define-integrable (*unparse-object object context)
   (unparse-object context object))
-
-(define-integrable (invoke-user-method method object context)
-  (method context object))
 
 (define dispatch-table)
 (add-boot-init!
@@ -891,10 +888,8 @@ USA.
 		(*unparse-datum promise context*)))))))
 
 (define (unparse/tagged-object object context)
-  (cond ((get-tagged-object-unparser-method object)
-	 => (lambda (method)
-	      (invoke-user-method method object context)))
-	(else
-	 (*unparse-with-brackets 'tagged-object object context
-	   (lambda (context*)
-	     (*unparse-object (tagged-object-tag object) context*))))))
\ No newline at end of file
+  (*unparse-with-brackets 'tagged-object object context
+    (lambda (context*)
+      (*unparse-object (tag-name (tagged-object-tag object)) context*)
+      (*unparse-string " " context*)
+      (*unparse-object (tagged-object-datum object) context*))))
\ No newline at end of file