Rework vector tag printer methods so they work again.

XXX Needs tests, but these are a pain to construct...

diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm
index 34f84b60761de06b4989fae539309e6b9fe4852d..949493454e0676f8ce2ebfa2f0ac5881babf5318 100644 (file)
--- a/src/compiler/base/object.scm
+++ b/src/compiler/base/object.scm
@@ -29,11 +29,13 @@ USA.
 (declare (usual-integrations))
 \f
 (define-structure (vector-tag
-                  (constructor %make-vector-tag (parent name index noop)))
+                  (constructor %make-vector-tag
+                               (parent name index predicate noop)))
   (parent false read-only true)
   (name false read-only true)
   (index false read-only true)
   (description false)
+  (predicate false read-only true)
   (method-alist '())
 
   ;; This property was stored in the method alist, but it is used so
@@ -42,30 +44,40 @@ USA.
   )
 
 (define make-vector-tag
-  (let ((root-tag (%make-vector-tag false 'OBJECT false false)))
-    (define-print-method (lambda (object)
-                          (and (vector? object)
-                               (fix:> (vector-length object) 0)
-                               (eq? root-tag (vector-ref object 0))))
-      (standard-print-method
-       (lambda (object)
-        (string "LIAR:" (vector-tag-name (tagged-vector/tag object))))))
+  (let ()
+    (define (root-tagged-vector? object)
+      (and (vector? object)
+          (fix:> (vector-length object) 0)
+          (eq? root-tag (vector-ref object 0))))
+    (define root-tag
+      (%make-vector-tag false 'OBJECT false root-tagged-vector? false))
+    (register-predicate! root-tagged-vector? 'root-tagged-vector?
+                        '<= vector?)
     (named-lambda (make-vector-tag parent name enumeration)
-      (%make-vector-tag (or parent root-tag)
-                       name
-                       (and enumeration
-                            (enumeration/name->index enumeration
-                                                     name))
-                       ;; Propagate this downward at construction time
-                       ;; to avoid having to crawl upward at use time.
-                       (and parent (vector-tag-noop parent))))))
+      (define (predicate object)
+       (and (vector? object)
+            (fix:> (vector-length object) 0)
+            (eq? tag (vector-ref object 0))))
+      (define tag
+       (%make-vector-tag (or parent root-tag)
+                         name
+                         (and enumeration
+                              (enumeration/name->index enumeration
+                                                       name))
+                         predicate
+                         ;; Propagate this downward at construction time
+                         ;; to avoid having to crawl upward at use time.
+                         (and parent (vector-tag-noop parent))))
+      (register-predicate! predicate (symbol name '?)
+                          '<= (vector-tag-predicate (or parent root-tag)))
+      (define-print-method predicate
+       (standard-print-method
+        (lambda (object)
+          (string "LIAR:" (vector-tag-name (tagged-vector/tag object))))))
+      tag)))
 
 (define (define-vector-tag-unparser tag unparser)
-  (define-print-method (lambda (object)
-                        (and (vector? object)
-                             (fix:> (vector-length object) 0)
-                             (eq? tag (vector-ref object 0))))
-    unparser)
+  (define-print-method (vector-tag-predicate tag) unparser)
   (vector-tag-name tag))
 
 (define (vector-tag-put! tag key value)