From: sybok Date: Thu, 29 Aug 1991 19:01:45 +0000 (+0000) Subject: The pretty-print has been changed to allow the X-Git-Tag: 20090517-FFI~10258 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2d9b18ffd052a97441687bf12fee90b9c665342f;p=mit-scheme.git The pretty-print has been changed to allow the printing of circular structures in closed form. Just fluid-let the variable *pp-avoid-circularity?* to #t. (The default is #f.) --- diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm index afec1f237..c6fec8818 100644 --- a/v7/src/runtime/pp.scm +++ b/v7/src/runtime/pp.scm @@ -1,6 +1,7 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.20 1991/08/29 17:40:09 sybok Exp $ +$Header: /nfs/altdorf/root/scheme/src/runtime/RCS/pp.scm,v 14.20 1991/08/29 +17:40:09 sybok Exp sybok $ Copyright (c) 1988-1991 Massachusetts Institute of Technology @@ -54,6 +55,7 @@ MIT in each case. |# (NAMED-LAMBDA . ,print-procedure))) (set! dispatch-list code-dispatch-list) (set! dispatch-default print-combination) + (set! cocked-object (generate-uninterned-symbol 'cocked-object)) unspecific) @@ -124,7 +126,9 @@ MIT in each case. |# (fluid-let ((x-size (or *pp-forced-x-size* (output-port/x-size port))) (output-port port)) (let* ((numerical-walk - (if *pp-avoid-circularity?* numerical-walk-avoid-circularities numerical-walk)) + (if *pp-avoid-circularity?* + numerical-walk-avoid-circularities + numerical-walk)) (node (numerical-walk expression list-depth))) (if (positive? indentation) (*unparse-string (make-string indentation #\space))) @@ -622,7 +626,9 @@ MIT in each case. |# (define (walk-highlighted-object object list-depth) (let ((dl (pph/depth-limit object)) (numerical-walk - (if *pp-avoid-circularity?* numerical-walk-avoid-circularities numerical-walk))) + (if *pp-avoid-circularity?* + numerical-walk-avoid-circularities + numerical-walk))) (fluid-let ((*unparser-list-breadth-limit* (let ((bl (pph/breadth-limit object))) (if (eq? bl 'default) @@ -638,15 +644,15 @@ MIT in each case. |# 0))))) -;;; The following are circular list/vector handing procedures. They allow +;;; The following are circular list/vector handing procedures. They allow ;;; arbitary circular constructions made from pairs and vectors to be printed ;;; in closed form. The term "current parenthetical level" means the lowest -;;; parethetical level which contains the circularity object. Expressions like -;;; "up 1 parenthetical level" refer to the object which is one parenthetical -;;; level above the lowest parenthetical level which contains the circularity -;;; object--i.e., the second lowest parenthetical level which contains the -;;; circularity object. -;;; Finally, the expression, "up 1 parenthetical level, downstream 1 cdr," +;;; parethetical level which contains the circularity object. Expressions +;;; like "up 1 parenthetical level" refer to the object which is one +;;; parenthetical level above the lowest parenthetical level which contains +;;; the circularity object--i.e., the second lowest parenthetical level +;;; which contains the circularity object. +;;; Finally, the expression, "up 1 parenthetical level, downstream 1 cdr," ;;; means that to find the object being referred to, you should go to the ;;; parenthetical level one level above the lowest parenthetical level which ;;; contains the circularity object, and then take the cdr of that list. @@ -661,7 +667,8 @@ MIT in each case. |# (numerical-walk-terminating exp (cons exp (make-queue)) list-depth)) -;; This numerical walker has special pair and vector walkers to guarantee proper termination. +;; This numerical walker has special pair and vector walkers to guarantee +;; proper termination. (define (numerical-walk-terminating object half-pointer/queue list-depth) (define queue (cdr half-pointer/queue)) @@ -669,14 +676,17 @@ MIT in each case. |# (cond ((pair? object) (let ((prefix (unparse-list/prefix-pair? object))) (if prefix - (make-prefix-node prefix - (numerical-walk-terminating (cadr object) - (advance half-pointer (update-queue queue '(cdr car))) - list-depth)) + (make-prefix-node + prefix + (numerical-walk-terminating + (cadr object) + (advance half-pointer (update-queue queue '(cdr car))) + list-depth)) (let ((unparser (unparse-list/unparser object))) (if unparser (walk-custom unparser object list-depth) - (walk-pair-terminating object half-pointer/queue list-depth)))))) + (walk-pair-terminating object half-pointer/queue + list-depth)))))) ((symbol? object) (if (or *pp-uninterned-symbols-by-name* (object-type? (ucode-type interned-symbol) object)) @@ -698,7 +708,11 @@ MIT in each case. |# (let ((unparser (unparse-vector/unparser object))) (if unparser (walk-custom unparser object list-depth) - (make-prefix-node "#" (walk-vector-terminating (vector->list object) half-pointer/queue list-depth)))))) + (make-prefix-node + "#" + (walk-vector-terminating + (vector->list object) + half-pointer/queue list-depth)))))) ((primitive-procedure? object) (if *pp-primitives-by-name* (primitive-procedure-name object) @@ -714,43 +728,65 @@ MIT in each case. |# (no-highlights? pair)) "..." (let ((list-depth (+ list-depth 1))) - (let loop ((pair pair) (list-breadth 0) (half-pointer/queue half-pointer/queue)) + (let loop ((pair pair) (list-breadth 0) + (half-pointer/queue half-pointer/queue)) (cond ((and *unparser-list-breadth-limit* (>= list-breadth *unparser-list-breadth-limit*) (no-highlights? pair)) (make-singleton-list-node "...")) ((null? (cdr pair)) (make-singleton-list-node - (let ((half-pointer/queue (advance (car half-pointer/queue) (update-queue (cdr half-pointer/queue) '(car))))) + (let ((half-pointer/queue + (advance + (car half-pointer/queue) + (update-queue (cdr half-pointer/queue) '(car))))) (if (eq? (car half-pointer/queue) (car pair)) (circularity-string (cdr half-pointer/queue)) - (numerical-walk-terminating (car pair) half-pointer/queue list-depth))))) + (numerical-walk-terminating + (car pair) half-pointer/queue list-depth))))) (else (make-list-node - (let ((half-pointer/queue (advance (car half-pointer/queue) (update-queue (cdr half-pointer/queue) '(car))))) + (let ((half-pointer/queue + (advance + (car half-pointer/queue) + (update-queue (cdr half-pointer/queue) '(car))))) (if (eq? (car half-pointer/queue) (car pair)) (circularity-string (cdr half-pointer/queue)) - (numerical-walk-terminating (car pair) half-pointer/queue list-depth))) + (numerical-walk-terminating + (car pair) half-pointer/queue list-depth))) (let ((list-breadth (+ list-breadth 1))) - (if (and (pair? (cdr pair)) - (not (unparse-list/unparser (cdr pair)))) - (let ((half-pointer/queue (advance (car half-pointer/queue) (update-queue (cdr half-pointer/queue) '(cdr))))) + (if + (and (pair? (cdr pair)) + (not (unparse-list/unparser (cdr pair)))) + (let ((half-pointer/queue + (advance + (car half-pointer/queue) + (update-queue (cdr half-pointer/queue) '(cdr))))) + (if (eq? (car half-pointer/queue) (cdr pair)) + (make-singleton-list-node + (string-append + ". " + (circularity-string (cdr half-pointer/queue)))) + (loop (cdr pair) list-breadth half-pointer/queue))) + (make-list-node + "." + (make-singleton-list-node + (if + (and *unparser-list-breadth-limit* + (>= list-breadth + *unparser-list-breadth-limit*) + (no-highlights? pair)) + "..." + (let ((half-pointer/queue + (advance + (car half-pointer/queue) + (update-queue + (cdr half-pointer/queue) '(cdr))))) (if (eq? (car half-pointer/queue) (cdr pair)) - (make-singleton-list-node - (string-append ". " (circularity-string (cdr half-pointer/queue)))) - (loop (cdr pair) list-breadth half-pointer/queue))) - (make-list-node - "." - (make-singleton-list-node - (if (and *unparser-list-breadth-limit* - (>= list-breadth - *unparser-list-breadth-limit*) - (no-highlights? pair)) - "..." - (let ((half-pointer/queue (advance (car half-pointer/queue) (update-queue (cdr half-pointer/queue) '(cdr))))) - (if (eq? (car half-pointer/queue) (cdr pair)) - (circularity-string (cdr half-pointer/queue)) - (numerical-walk-terminating (cdr pair) half-pointer/queue list-depth))))))))))))))) + (circularity-string (cdr half-pointer/queue)) + (numerical-walk-terminating + (cdr pair) + half-pointer/queue list-depth))))))))))))))) (define (walk-vector-terminating pair half-pointer/queue list-depth) (if (and *unparser-list-depth-limit* @@ -765,16 +801,25 @@ MIT in each case. |# (make-singleton-list-node "...")) ((null? (cdr pair)) (make-singleton-list-node - (let ((half-pointer/queue (advance (car half-pointer/queue) (update-queue (cdr half-pointer/queue) (list list-breadth))))) + (let ((half-pointer/queue + (advance + (car half-pointer/queue) + (update-queue + (cdr half-pointer/queue) (list list-breadth))))) (if (eq? (car half-pointer/queue) (car pair)) (circularity-string (cdr half-pointer/queue)) - (numerical-walk-terminating (car pair) half-pointer/queue list-depth))))) + (numerical-walk-terminating + (car pair) half-pointer/queue list-depth))))) (else (make-list-node - (let ((half-pointer/queue (advance (car half-pointer/queue) (update-queue (cdr half-pointer/queue) (list list-breadth))))) + (let ((half-pointer/queue + (advance (car half-pointer/queue) + (update-queue (cdr half-pointer/queue) + (list list-breadth))))) (if (eq? (car half-pointer/queue) (car pair)) (circularity-string (cdr half-pointer/queue)) - (numerical-walk-terminating (car pair) half-pointer/queue list-depth))) + (numerical-walk-terminating + (car pair) half-pointer/queue list-depth))) (let ((list-breadth (+ list-breadth 1))) (if (not (unparse-list/unparser (cdr pair))) (loop (cdr pair) list-breadth) @@ -786,13 +831,15 @@ MIT in each case. |# *unparser-list-breadth-limit*) (no-highlights? pair)) "..." - (numerical-walk-terminating (cdr pair) half-pointer/queue list-depth))))))))))))) + (numerical-walk-terminating + (cdr pair) + half-pointer/queue list-depth))))))))))))) ;;;; These procedures allow the walkers to interact with the queue. -(define cocked-object (generate-uninterned-symbol 'cocked-object)) +(define cocked-object) (define (advance half-object queue) (cond ((vector? half-object) @@ -819,7 +866,8 @@ MIT in each case. |# ((eq? (car command-list) 'cdr) (uq-iter (add-cdr queue) (cdr command-list))) (else - (uq-iter (add-vector-ref (car command-list) queue) (cdr command-list))))) + (uq-iter (add-vector-ref (car command-list) queue) + (cdr command-list))))) (uq-iter queue command-list)) (define (add-car queue) @@ -878,8 +926,9 @@ MIT in each case. |# (make-queue (cons head (cons 1 (cdr tail))) (queue/past-cdrs queue))) (begin (fluid-vector-set! (cdr tail) (car tail) object) - (make-queue (cons head - (if (= (car tail) (-1+ virtual-fluid-vector-length)) + (make-queue (cons + head + (if (= (car tail) (-1+ virtual-fluid-vector-length)) (cons 0 (fluid-vector-extend (cdr tail))) (cons (1+ (car tail)) (cdr tail)))) (queue/past-cdrs queue)))))) @@ -911,8 +960,12 @@ MIT in each case. |# (define (flatten starting-vector starting-n ending-vector ending-n) (if (eq? starting-vector ending-vector) (vector->list (subvector starting-vector starting-n ending-n)) - (append (vector->list (subvector starting-vector starting-n virtual-fluid-vector-length)) - (flatten (vector-ref starting-vector virtual-fluid-vector-length) 0 ending-vector ending-n)))) + (append + (vector->list + (subvector starting-vector starting-n virtual-fluid-vector-length)) + (flatten + (vector-ref starting-vector virtual-fluid-vector-length) 0 + ending-vector ending-n)))) (define (proc-list-iter list code-cache) (cond ((null? list) (if (eq? code-cache -2) 1 0)) ((>= (car list) 0) @@ -925,7 +978,8 @@ MIT in each case. |# (let* ((cell (queue/cons-cell queue)) (head (car cell)) (tail (cdr cell)) - (operating-list (flatten (cdr head) (car head) (cdr tail) (car tail)))) + (operating-list + (flatten (cdr head) (car head) (cdr tail) (car tail)))) (proc-list-iter operating-list #f))) @@ -938,11 +992,14 @@ MIT in each case. |# (cond ((= depth 1) "#[circularity (current parenthetical level") ((= depth 2) "#[circularity (up 1 parenthetical level") (else - (string-append "#[circularity (up " (number->string (-1+ depth)) " parenthetical levels"))) + (string-append "#[circularity (up " + (number->string (-1+ depth)) + " parenthetical levels"))) (cond ((= cdrs 0) ")]") ((= cdrs 1) ", downstream 1 cdr.)]") (else - (string-append ", downstream " (number->string cdrs) " cdrs.)]")))))) + (string-append ", downstream " + (number->string cdrs) " cdrs.)]")))))) ;;;; Node Model @@ -1011,4 +1068,15 @@ MIT in each case. |# (constructor make-highlighted-node)) (size false read-only true) (highlight false read-only true) - (subnode false read-only true)) \ No newline at end of file + (subnode false read-only true)) + + + + + + + + + + +