Put back support for printing tagged lists and vectors when built by 9.2.

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index e90f897e7780365a88818ae3269a150821ce70c3..e49267301503766564581b6cd9da69d291dfee85 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -412,44 +412,36 @@ USA.
 (define structure-type/field-indexes)
 (define structure-type/default-inits)
 (define structure-type/unparser-method)
-(define set-structure-type/unparser-method!)
 (define structure-type/tag)
 (define structure-type/length)
 (add-boot-init!
  (lambda ()
+   ;; unparser-method arg should be removed after 9.3 is released.
    (set! rtd:structure-type
         (make-record-type "structure-type"
-                          '(PHYSICAL-TYPE NAME FIELD-NAMES FIELD-INDEXES
-                                          DEFAULT-INITS TAG LENGTH)))
+                          '(physical-type name field-names field-indexes
+                                          default-inits unparser-method tag
+                                          length)))
    (set! make-define-structure-type
-        (let ((constructor (record-constructor rtd:structure-type)))
-          (lambda (physical-type name field-names field-indexes default-inits
-                                 unparser-method tag length)
-            ;; unparser-method arg should be removed after 9.3 is released.
-            (declare (ignore unparser-method))
-            (constructor physical-type
-                         name
-                         field-names
-                         field-indexes
-                         default-inits
-                         tag
-                         length))))
+        (record-constructor rtd:structure-type))
    (set! structure-type?
         (record-predicate rtd:structure-type))
    (set! structure-type/physical-type
-        (record-accessor rtd:structure-type 'PHYSICAL-TYPE))
+        (record-accessor rtd:structure-type 'physical-type))
    (set! structure-type/name
-        (record-accessor rtd:structure-type 'NAME))
+        (record-accessor rtd:structure-type 'name))
    (set! structure-type/field-names
-        (record-accessor rtd:structure-type 'FIELD-NAMES))
+        (record-accessor rtd:structure-type 'field-names))
    (set! structure-type/field-indexes
-        (record-accessor rtd:structure-type 'FIELD-INDEXES))
+        (record-accessor rtd:structure-type 'field-indexes))
    (set! structure-type/default-inits
-        (record-accessor rtd:structure-type 'DEFAULT-INITS))
+        (record-accessor rtd:structure-type 'default-inits))
+   (set! structure-type/unparser-method
+        (record-accessor rtd:structure-type 'unparser-method))
    (set! structure-type/tag
-        (record-accessor rtd:structure-type 'TAG))
+        (record-accessor rtd:structure-type 'tag))
    (set! structure-type/length
-        (record-accessor rtd:structure-type 'LENGTH))
+        (record-accessor rtd:structure-type 'length))
    unspecific))
 
 (define-integrable (structure-type/field-index type field-name)
@@ -501,6 +493,21 @@ USA.
        (and (structure-type? type)
             type))))
 
+;;; Starting here can be removed after 9.3 release...
+
+(define (named-list-with-unparser? object)
+  (and (named-list? object)
+       (tag->unparser-method (car object))))
+
+(define (named-vector-with-unparser? object)
+  (and (named-vector? object)
+       (tag->unparser-method (vector-ref object 0))))
+
+(define (tag->unparser-method tag)
+  (structure-type/unparser-method (tag->structure-type tag)))
+
+;;; ...and ending here.
+
 (define-pp-describer named-list?
   (lambda (pair)
     (let ((type (tag->structure-type (car pair))))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 8ca90237796cfa48c34c2e9bf8ee76a476224d82..a8c7e2242bf0c208c703877d3159ce3c0c7abaed 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3728,6 +3728,9 @@ USA.
          error:no-such-slot
          error:uninitialized-slot
          record-type-field-index)
+  (export (runtime unparser)
+         named-list-with-unparser?
+         named-vector-with-unparser?)
   (initialization (initialize-package!)))
 
 (define-package (runtime reference-trap)

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index d32b6df3996ff2a77f387ca9c55938401a310715..42da226e6674d264ac8a119b88ac756f8be06563 100644 (file)
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -565,26 +565,30 @@ USA.
           (loop (fix:- index 1))))))
 \f
 (define (unparse/vector vector context)
-  (limit-unparse-depth context
-    (lambda (context*)
-      (let ((end (vector-length vector)))
-       (if (fix:> end 0)
-           (begin
-             (*unparse-string "#(" context*)
-             (*unparse-object (safe-vector-ref vector 0) context*)
-             (let loop ((index 1))
-               (if (fix:< index end)
-                   (if (let ((limit (context-list-breadth-limit context*)))
-                         (and limit
-                              (>= index limit)))
-                       (*unparse-string " ...)" context*)
-                       (begin
-                         (*unparse-char #\space context*)
-                         (*unparse-object (safe-vector-ref vector index)
-                                          context*)
-                         (loop (fix:+ index 1))))))
-             (*unparse-char #\) context*))
-           (*unparse-string "#()" context*))))))
+  (let ((unparser (named-vector-with-unparser? vector)))
+    (if unparser
+       (unparser context vector)
+       (limit-unparse-depth context
+         (lambda (context*)
+           (let ((end (vector-length vector)))
+             (if (fix:> end 0)
+                 (begin
+                   (*unparse-string "#(" context*)
+                   (*unparse-object (safe-vector-ref vector 0) context*)
+                   (let loop ((index 1))
+                     (if (fix:< index end)
+                         (if (let ((limit
+                                    (context-list-breadth-limit context*)))
+                               (and limit
+                                    (>= index limit)))
+                             (*unparse-string " ...)" context*)
+                             (begin
+                               (*unparse-char #\space context*)
+                               (*unparse-object (safe-vector-ref vector index)
+                                                context*)
+                               (loop (fix:+ index 1))))))
+                   (*unparse-char #\) context*))
+                 (*unparse-string "#()" context*))))))))
 
 (define (safe-vector-ref vector index)
   (if (with-absolutely-no-interrupts
@@ -634,6 +638,8 @@ USA.
          => (lambda (prefix) (unparse-list/prefix-pair prefix pair context)))
         ((and (get-param:unparse-streams?) (stream-pair? pair))
          (unparse-list/stream-pair pair context))
+       ((named-list-with-unparser? pair)
+        => (lambda (unparser) (unparser context pair)))
         (else
          (unparse-list pair context))))