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 ac772f8c7853b2ca1d653d279d615b7199e05861..be76f2e4bb5e0d70fbddafa5cf3e1e84502fd457 100644 (file)
--- 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))
 \f
 ;;;; 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)
 \f
-(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 92ad4f9c4fecda93aa7acb01ef097f3dc88e087f..f473420c4cb8d64078494fbecc397a892040bb94 100644 (file)
--- 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 39783ab9db7280d173a0f4aaa2905309d13e789e..a1aec9ef3ee06bf435adb4b3190fd0856dcdfc65 100644 (file)
--- 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))
 \f
 (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