From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 23 Feb 2018 07:36:24 +0000 (-0800)
Subject: Put back support for printing tagged lists and vectors when built by 9.2.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~227
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4c022360ec50077e083fdeda2b1b3865f66545ef;p=mit-scheme.git

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 e90f897e7..e49267301 100644
--- 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 8ca902377..a8c7e2242 100644
--- 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 d32b6df39..42da226e6 100644
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -565,26 +565,30 @@ USA.
           (loop (fix:- index 1))))))
 
 (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))))