#| -*-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
(NAMED-LAMBDA . ,print-procedure)))
(set! dispatch-list code-dispatch-list)
(set! dispatch-default print-combination)
+ (set! cocked-object (generate-uninterned-symbol 'cocked-object))
unspecific)
(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)))
(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)
0)))))
\f
-;;; 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.
(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))
(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))
(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)
(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*
(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)
*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)))))))))))))
\f
;;;; 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)
((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)
(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))))))
(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)
(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)))
\f
(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.)]"))))))
\f
;;;; Node Model
(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))
+
+
+
+
+
+
+
+
+
+
+
projects / mit-scheme.git / commitdiff