From: Chris Hanson Date: Wed, 19 Sep 1990 00:35:10 +0000 (+0000) Subject: Fix pretty printer's handling of custom pair and vector unparsers. X-Git-Tag: 20090517-FFI~11178 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f59b0e2946fc27311326b261e7fb2ee782c4a0ec;p=mit-scheme.git Fix pretty printer's handling of custom pair and vector unparsers. --- diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm index f9539d312..48403dce9 100644 --- a/v7/src/runtime/pp.scm +++ b/v7/src/runtime/pp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.11 1990/09/13 23:46:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.12 1990/09/19 00:34:36 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -336,19 +336,17 @@ MIT in each case. |# (define (numerical-walk object list-depth) (cond ((pair? object) - (let ((unparser (unparse-list/unparser object))) - (if unparser - (let ((prefix (unparse-list/prefix-pair? object))) - (if prefix - (make-prefix-node prefix - (numerical-walk (cadr object) - list-depth)) - (walk-custom unparser object list-depth))) - (walk-pair object list-depth)))) + (let ((prefix (unparse-list/prefix-pair? object))) + (if prefix + (make-prefix-node prefix + (numerical-walk (cadr object) + list-depth)) + (let ((unparser (unparse-list/unparser object))) + (if unparser + (walk-custom unparser object list-depth) + (walk-pair object list-depth)))))) ((vector? object) - (let ((unparser - (and (not (zero? (vector-length object))) - (unparse-vector/unparser object)))) + (let ((unparser (unparse-vector/unparser object))) (if unparser (walk-custom unparser object list-depth) (make-prefix-node "#" diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm index 3bae1e8b3..b4f8ec1ec 100644 --- a/v7/src/runtime/unpars.scm +++ b/v7/src/runtime/unpars.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.17 1990/09/13 23:08:07 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.18 1990/09/19 00:34:16 cph Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -357,16 +357,14 @@ MIT in each case. |# (loop (-1+ index)))))) (define (unparse/vector vector) - ((or (unparse-vector/unparser vector) unparse-vector/normal) vector)) + (let ((method (unparse-vector/unparser vector))) + (if method + (invoke-user-method method vector) + (unparse-vector/normal vector)))) (define (unparse-vector/unparser vector) (and (not (zero? (vector-length vector))) - (let ((tag (safe-vector-ref vector 0))) - (and (not (future? tag)) - (let ((method (unparser/tagged-vector-method tag))) - (and method - (lambda (object) - (invoke-user-method method object)))))))) + (unparser/tagged-vector-method (safe-vector-ref vector 0)))) (define (unparse-vector/normal vector) (limit-unparse-depth @@ -395,11 +393,17 @@ MIT in each case. |# (vector-ref vector index)) (object-type? (ucode-type manifest-special-nm-vector) (vector-ref vector index))))) - (error "Attempt to unparse partially marked vector" 0)) + (error "Attempt to unparse partially marked vector")) (vector-ref vector index)) (define (unparse/pair pair) - ((or (unparse-list/unparser pair) unparse-list) pair)) + (let ((prefix (unparse-list/prefix-pair? pair))) + (if prefix + (unparse-list/prefix-pair prefix pair) + (let ((method (unparse-list/unparser pair))) + (if method + (invoke-user-method method pair) + (unparse-list pair)))))) (define (unparse-list list) (limit-unparse-depth @@ -419,35 +423,36 @@ MIT in each case. |# (define (unparse-tail l n) (cond ((pair? l) - (let ((unparser (unparse-list/unparser l))) - (if unparser - (begin (*unparse-string " . ") - (unparser l)) - (begin (*unparse-char #\Space) - (*unparse-object (car l)) - (if (and *unparser-list-breadth-limit* - (>= n *unparser-list-breadth-limit*) - (not (null? (cdr l)))) - (*unparse-string " ...") - (unparse-tail (cdr l) (1+ n))))))) + (let ((prefix (unparse-list/prefix-pair? l))) + (if prefix + (unparse-list/prefix-pair prefix l) + (let ((method (unparse-list/unparser l))) + (if method + (begin + (*unparse-string " . ") + (invoke-user-method method l)) + (begin + (*unparse-char #\space) + (*unparse-object (car l)) + (if (and *unparser-list-breadth-limit* + (>= n *unparser-list-breadth-limit*) + (not (null? (cdr l)))) + (*unparse-string " ...") + (unparse-tail (cdr l) (1+ n))))))))) ((not (null? l)) (*unparse-string " . ") (*unparse-object l)))) -(define (unparse-list/unparser object) - (and (not (future? (car object))) - (let ((prefix (unparse-list/prefix-pair? object))) - (if prefix - (lambda (pair) - (*unparse-string prefix) - (*unparse-object (cadr pair))) - (let ((method (unparser/tagged-pair-method (car object)))) - (and method - (lambda (object) - (invoke-user-method method object)))))))) +(define-integrable (unparse-list/unparser object) + (unparser/tagged-pair-method (car object))) + +(define (unparse-list/prefix-pair prefix pair) + (*unparse-string prefix) + (*unparse-object (cadr pair))) (define (unparse-list/prefix-pair? object) - (and (pair? (cdr object)) + (and (not (future? (car object))) + (pair? (cdr object)) (null? (cddr object)) (case (car object) ((QUOTE) "'") diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 3e912401e..ca9684a94 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.95 1990/09/14 01:47:22 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.96 1990/09/19 00:35:10 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 95)) + (add-identification! "Runtime" 14 96)) (define microcode-system)