From 4c022360ec50077e083fdeda2b1b3865f66545ef Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 22 Feb 2018 23:36:24 -0800 Subject: [PATCH] Put back support for printing tagged lists and vectors when built by 9.2. --- src/runtime/record.scm | 51 +++++++++++++++++++++++------------------ src/runtime/runtime.pkg | 3 +++ src/runtime/unpars.scm | 46 +++++++++++++++++++++---------------- 3 files changed, 58 insertions(+), 42 deletions(-) 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)))) -- 2.25.1