#| -*-Scheme-*-

$Id: pp.scm,v 14.50 2006/03/02 20:52:57 cph Exp $

Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
Copyright 1992,1993,1994,1995,1996,1999 Massachusetts Institute of Technology
Copyright 2001,2002,2003,2005,2006 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; Pretty Printer
;;; package: (runtime pretty-printer)

(declare (usual-integrations))

(define (initialize-package!)
  (set! pp-description (make-generic-procedure 1 'PP-DESCRIPTION))
  (set-generic-procedure-default-generator! pp-description
    (lambda (generic tags)
      generic tags
      pp-description/default))
  (set! forced-indentation (special-printer kernel/forced-indentation))
  (set! pressured-indentation (special-printer kernel/pressured-indentation))
  (set! print-procedure (special-printer kernel/print-procedure))
  (set! print-let-expression (special-printer kernel/print-let-expression))
  (set! print-case-expression (special-printer kernel/print-case-expression))
  (set! code-dispatch-list
	`((COND . ,forced-indentation)
	  (CASE . ,print-case-expression)
	  (IF . ,forced-indentation)
	  (OR . ,forced-indentation)
	  (AND . ,forced-indentation)
	  (LET . ,print-let-expression)
	  (LET* . ,print-let-expression)
	  (LETREC . ,print-let-expression)
	  (FLUID-LET . ,print-let-expression)
	  (DEFINE . ,print-procedure)
	  (DEFINE-INTEGRABLE . ,print-procedure)
	  (LAMBDA . ,print-procedure)
	  (NAMED-LAMBDA . ,print-procedure)))
  (set! dispatch-list code-dispatch-list)
  (set! dispatch-default print-combination)
  (set! cocked-object (generate-uninterned-symbol))
  unspecific)

(define *pp-named-lambda->define?* #f)
(define *pp-primitives-by-name* #t)
(define *pp-uninterned-symbols-by-name* #t)
(define *pp-no-highlights?* #t)
(define *pp-save-vertical-space?* #f)
(define *pp-lists-as-tables?* #t)
(define *pp-forced-x-size* #f)
(define *pp-avoid-circularity?* #f)
(define *pp-default-as-code?* #t)
(define *pp-auto-highlighter* #f)

(define (pp object #!optional port . rest)
  (let ((port (if (default-object? port) (current-output-port) port)))
    (let ((pretty-print
	   (lambda (object)
	     (apply pretty-print object port rest)
	     (newline port))))
      (cond ((pp-description object)
	     => (lambda (description)
		  (pretty-print object)
		  (for-each pretty-print description)))
	    ((arity-dispatched-procedure? object)
	     (pretty-print (unsyntax-entity object)))
	    ((and (procedure? object) (procedure-lambda object))
	     => pretty-print)
	    (else
	     (pretty-print object))))))

(define pp-description)

(define (pp-description/default object)
  (cond ((named-structure? object)
	 (named-structure/description object))
	((%record? object)		; unnamed record
	 (let loop ((i (- (%record-length object) 1)) (d '()))
	   (if (< i 0)
	       d
	       (loop (- i 1)
		     (cons (list i (%record-ref object i)) d)))))
	((weak-pair? object)
	 `((WEAK-CAR ,(weak-car object))
	   (WEAK-CDR ,(weak-cdr object))))
	((cell? object)
	 `((CONTENTS ,(cell-contents object))))
	(else
	 #f)))

;;; Controls the appearance of procedures in the CASE statement used
;;; to describe an arity dispatched procedure:
;;;  FULL:  full bodies of procedures
;;;  NAMED: just name if the procedure is a named lambda, like FULL if unnamed
;;;  SHORT: procedures appear in #[...] unparser syntax
(define *pp-arity-dispatched-procedure-style* 'FULL)

(define (unsyntax-entity object)
  (define (unsyntax-entry procedure)
    (case *pp-arity-dispatched-procedure-style*
      ((FULL)  (unsyntax-entity procedure))
      ((NAMED)
       (let ((text (unsyntax-entity procedure)))
	 (if (and (pair? text)
		  (eq? (car text) 'named-lambda)
		  (pair? (cdr text))
		  (pair? (cadr text)))
	     (caadr text)
	     text)))
      ((SHORT) procedure)
      (else procedure)))
  (cond ((arity-dispatched-procedure? object)
	 (let* ((default  (entity-procedure  object))
		(cases    (cdr (vector->list (entity-extra object))))
		(cases*
		 (let loop ((i 0) (tests '()) (cases cases))
		   (cond ((null? cases) (reverse tests))
			 ((car cases)
			  (loop (+ i 1)
				(cons `((,i) ,(unsyntax-entry (car cases)))
				      tests)
				(cdr cases)))
			 (else
			  (loop (+ i 1) tests (cdr cases)))))))
	   `(CASE NUMBER-OF-ARGUMENTS
	      ,@cases*
	      (ELSE
	       ,(unsyntax-entry default)))))
	((and (procedure? object) (procedure-lambda object))
	 => unsyntax)
	(else
	 object)))

(define (pretty-print object #!optional port as-code? indentation)
  (let ((as-code?
	 (if (default-object? as-code?)
	     (let ((default *pp-default-as-code?*))
	       (if (boolean? default)
		   default
		   (not (scode-constant? object))))
	     as-code?)))
    (pp-top-level (let ((sexp
			 (if (scode-constant? object)
			     object
			     (unsyntax object))))
		    (if (and as-code?
			     (pair? sexp)
			     (eq? (car sexp) 'NAMED-LAMBDA)
			     *pp-named-lambda->define?*)
			(if (and (eq? 'LAMBDA *pp-named-lambda->define?*)
				 (pair? (cdr sexp))
				 (pair? (cadr sexp)))
			    `(LAMBDA ,(cdadr sexp) ,@(cddr sexp))
			    `(DEFINE ,@(cdr sexp)))
			sexp))
		  (if (default-object? port) (current-output-port) port)
		  as-code?
		  (if (default-object? indentation) 0 indentation)
		  0)
    unspecific))

(define-structure (pretty-printer-highlight
		   (conc-name pph/)
		   (constructor
		    make-pretty-printer-highlight
		    (object #!optional
			    start-string end-string
			    as-code? depth-limit
			    breadth-limit)))
  (object #f read-only #t)
  (start-string "*=>" read-only #t)
  (end-string   "<=*" read-only #t)
  (as-code? 'DEFAULT read-only #t)
  (depth-limit 'DEFAULT read-only #t)
  (breadth-limit 'DEFAULT read-only #t))

(define (with-highlight-strings-printed pph thunk)
  (let ((print-string
	 (lambda (s)
	   (if (string? s)
	       (*unparse-string s)
	       (s output-port)))))
    (print-string (pph/start-string pph))
    (thunk)
    (print-string (pph/end-string pph))))

(define (pph/start-string-length pph)
  (let ((start (pph/start-string pph)))
    (if (string? start)
	(string-length start)
	0)))

(define (pph/end-string-length pph)
  (let ((end (pph/end-string pph)))
    (if (string? end)
	(string-length end)
	0)))

(define (pp-top-level expression port as-code? indentation list-depth)
  (fluid-let ((x-size (- (or *pp-forced-x-size* (output-port/x-size port)) 1))
	      (output-port port)
	      (*unparse-uninterned-symbols-by-name?*
	       *pp-uninterned-symbols-by-name*))
    (let* ((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)))
      (if as-code?
	  (print-node node indentation list-depth)
	  (print-non-code-node node indentation list-depth))
      (output-port/discretionary-flush port))))

(define x-size)
(define output-port)

(define-integrable (*unparse-char char)
  (output-port/write-char output-port char))

(define-integrable (*unparse-string string)
  (output-port/write-string output-port string))

(define-integrable (*unparse-open)
  (*unparse-char #\())

(define-integrable (*unparse-close)
  (*unparse-char #\)))

(define-integrable (*unparse-space)
  (*unparse-char #\space))

(define-integrable (*unparse-newline)
  (*unparse-char #\newline))

(define (print-non-code-node node column depth)
  (fluid-let ((dispatch-list '())
	      (dispatch-default
	       (if *pp-lists-as-tables?*
		   print-data-table
		   print-data-column)))
    (print-node node column depth)))

(define (print-code-node node column depth)
  (fluid-let ((dispatch-list code-dispatch-list)
	      (dispatch-default print-combination))
    (print-node node column depth)))

(define (print-data-column nodes column depth)
  (*unparse-open)
  (print-column nodes (+ column 1) (+ depth 1))
  (*unparse-close))

(define (print-data-table nodes column depth)
  (*unparse-open)
  (maybe-print-table nodes (+ column 1) (+ depth 1))
  (*unparse-close))

(define (print-node node column depth)
  (cond ((list-node? node)
	 (print-list-node node column depth))
	((symbol? node)
	 (*unparse-symbol node))
	((prefix-node? node)
	 (*unparse-string (prefix-node-prefix node))
	 (let ((new-column
		(+ column (string-length (prefix-node-prefix node))))
	       (subnode (prefix-node-subnode node)))
	   (if (null? dispatch-list)
	       (print-node subnode new-column depth)
	       (print-non-code-node subnode new-column depth))))
	((highlighted-node? node)
	 (let ((highlight (highlighted-node/highlight node)))
	   (with-highlight-strings-printed highlight
	     (lambda ()
	       (let ((handler
		      (let ((as-code? (pph/as-code? highlight))
			    (currently-as-code? (not (null? dispatch-list))))
			(cond ((or (eq? as-code? 'DEFAULT)
				   (eq? as-code? currently-as-code?))
			       print-node)
			      (as-code?
			       print-code-node)
			      (else
			       print-non-code-node)))))
		 (handler (highlighted-node/subnode node)
			  (+ column (pph/start-string-length highlight))
			  (+ depth (pph/end-string-length highlight))))))))
	(else
	 (*unparse-string node))))

(define (print-list-node node column depth)
  (if (and *pp-save-vertical-space?*
	   (fits-within? node column depth))
      (print-guaranteed-list-node node)
      (let* ((subnodes (node-subnodes node))
	     (association
	      (and (not (null? (cdr subnodes)))
		   (assq (unhighlight (car subnodes)) dispatch-list))))
	(if (and (not association)
		 (fits-within? node column depth))
	    (print-guaranteed-list-node node)
	    ((if association
		 (cdr association)
		 dispatch-default)
	     subnodes column depth)))))

(define (print-guaranteed-node node)
  (cond ((list-node? node)
	 (print-guaranteed-list-node node))
	((symbol? node)
	 (*unparse-symbol node))
	((highlighted-node? node)
	 (with-highlight-strings-printed (highlighted-node/highlight node)
	   (lambda ()
	     (print-guaranteed-node (highlighted-node/subnode node)))))
	((prefix-node? node)
	 (*unparse-string (prefix-node-prefix node))
	 (print-guaranteed-node (prefix-node-subnode node)))
	(else
	 (*unparse-string node))))

(define (print-guaranteed-list-node node)
  (*unparse-open)
  (let loop ((nodes (node-subnodes node)))
    (print-guaranteed-node (car nodes))
    (if (not (null? (cdr nodes)))
	(begin
	  (*unparse-space)
	  (loop (cdr nodes)))))
  (*unparse-close))

(define (print-column nodes column depth)
  (let loop ((nodes nodes))
    (if (null? (cdr nodes))
	(print-node (car nodes) column depth)
	(begin
	  (print-node (car nodes) column 0)
	  (tab-to column)
	  (loop (cdr nodes))))))

(define (print-guaranteed-column nodes column)
  (let loop ((nodes nodes))
    (print-guaranteed-node (car nodes))
    (if (not (null? (cdr nodes)))
	(begin
	  (tab-to column)
	  (loop (cdr nodes))))))

(define (print-guaranteed-table nodes column all-widths)
  (define (print-row row widths spaces)
    (cond ((null? row)
	   unspecific)
	  ((null? widths)
	   (tab-to column)
	   (print-row row all-widths 0))
	  (else
	   (let ((next (car row)))
	     (pad-with-spaces spaces)
	     (print-guaranteed-node next)
	     (print-row (cdr row)
			(cdr widths)
			(1+ (- (car widths)
			       (node-size next))))))))
  (print-row nodes all-widths 0))

(define (maybe-print-table nodes column depth)
  (define (default)
    (print-column nodes column depth))

  (let* ((available-space (- x-size column))
	 (n-nodes (length nodes))
	 (max-cols (quotient (+ n-nodes 1) 2)))

    (define (try-columns n-columns)
      (let* ((nodev (list->vector nodes))
	     (last-size (node-size (vector-ref nodev (-1+ n-nodes)))))

	(define (fit? n-cols widths)
	  ;; This must check that all rows fit.
	  ;; The last one must be treated specially because it is
	  ;; followed by depth tokens (close parens).
	  (and (>= available-space (+ (-1+ n-cols) (reduce + 0 widths)))
	       (let ((last-n-1 (remainder (-1+ n-nodes) n-cols)))
		 (>= available-space
		     (+ (+ last-n-1 (reduce + 0 (list-head widths last-n-1)))
			(+ last-size depth))))))

	(define (find-max-width posn step)
	  (let loop ((posn posn)
		     (width 0))
	    (if (>= posn n-nodes)
		width
		(let ((next (node-size (vector-ref nodev posn))))
		  (loop (+ posn step)
			(if (> next width) next width))))))

	(define (find-widths n)
	  (let recur ((start 0))
	    (if (= start n)
		'()
		(cons (find-max-width start n) (recur (1+ start))))))

	(define (try n)
	  (if (< n 2)
	      (default)
	      (let ((widths (find-widths n)))
		(if (not (fit? n widths))
		    (try (- n 1))
		    (print-guaranteed-table
		     nodes column
		     ;; Try to make it look pretty.
		     (let ((next-n (-1+ n)))
		       (if (or (= n 2)
			       (not (= (quotient (+ n-nodes next-n) n)
				       (quotient (+ n-nodes (-1+ next-n))
						 next-n))))
			   widths
			   (let ((nwidths (find-widths next-n)))
			     (if (fit? (-1+ n) nwidths)
				 nwidths
				 widths)))))))))

	(try n-columns)))

    (if (< n-nodes 4)
	;; It's silly to tabulate 3 or less things.
	(default)
	(let loop ((n 1)
		   (nodes (cdr nodes))
		   (space (- available-space
			     (node-size (car nodes)))))
	  (cond ((> n max-cols)
		 ;; Make sure there are at least two relatively full rows.
		 ;; This also guarantees that nodes is not NULL?.
		 (try-columns max-cols))
		((>= space 0)
		 (loop (1+ n)
		       (cdr nodes)
		       (- space (1+ (node-size (car nodes))))))
		((<= n 2)
		 (default))
		(else
		 (try-columns (-1+ n))))))))

;;;; Printers

(define (print-combination nodes column depth)
  (*unparse-open)
  (let ((column (+ column 1))
	(depth (+ depth 1)))
    (cond ((null? (cdr nodes))
	   (print-node (car nodes) column depth))
	  ((two-on-first-line? nodes column depth)
	   (print-guaranteed-node (car nodes))
	   (*unparse-space)
	   (print-guaranteed-column (cdr nodes)
				    (+ column 1 (node-size (car nodes)))))
	  (else
	   (print-column nodes column depth))))
  (*unparse-close))

(define dispatch-list)
(define dispatch-default)
(define code-dispatch-list)

(define ((special-printer procedure) nodes column depth)
  (*unparse-open)
  (print-guaranteed-node (car nodes))	;(*unparse-symbol (car nodes))
  (*unparse-space)
  (if (not (null? (cdr nodes)))
      (procedure (cdr nodes)
		 (+ column 2 (node-size (car nodes)))
		 (+ column 2)
		 (+ depth 1)))
  (*unparse-close))

;;; Force the indentation to be an optimistic column.

(define forced-indentation)
(define (kernel/forced-indentation nodes optimistic pessimistic depth)
  pessimistic
  (print-column nodes optimistic depth))

;;; Pressure the indentation to be an optimistic column; no matter
;;; what happens, insist on a column, but accept a pessimistic one if
;;; necessary.

(define pressured-indentation)
(define (kernel/pressured-indentation nodes optimistic pessimistic depth)
  (if (fits-as-column? nodes optimistic depth)
      (print-guaranteed-column nodes optimistic)
      (begin
	(tab-to pessimistic)
	(print-column nodes pessimistic depth))))

;;; Print a procedure definition.  The bound variable pattern goes on
;;; the same line as the keyword, while everything else gets indented
;;; pessimistically.  We may later want to modify this to make higher
;;; order procedure patterns be printed more carefully.

(define print-procedure)
(define (kernel/print-procedure nodes optimistic pessimistic depth)
  (print-node (car nodes) optimistic 0)
  (let ((rest (cdr nodes)))
    (if (not (null? rest))
	(begin
	  (tab-to pessimistic)
	  (print-column (cdr nodes) pessimistic depth)))))

;;; Print a binding form.  There is a great deal of complication here,
;;; some of which is to gracefully handle the case of a badly-formed
;;; binder.  But most important is the code that handles the name when
;;; we encounter a named let; it must go on the same line as the
;;; keyword.  In that case, the bindings try to fit on that line or
;;; start on that line if possible; otherwise they line up under the
;;; name.  The body, of course, is always indented pessimistically.

(define print-let-expression)
(define (kernel/print-let-expression nodes optimistic pessimistic depth)
  (let ((print-body
	 (lambda (nodes)
	   (if (not (null? nodes))
	       (begin
		 (tab-to pessimistic)
		 (print-column nodes pessimistic depth))))))
    (cond ((null? (cdr nodes))
	   ;; screw case
	   (print-node (car nodes) optimistic depth))
	  ((symbol? (car nodes))
	   ;; named let
	   (*unparse-symbol (car nodes))
	   (let ((new-optimistic
		  (+ optimistic (+ 1 (symbol-length (car nodes))))))
	     (cond ((fits-within? (cadr nodes) new-optimistic 0)
		    (*unparse-space)
		    (print-guaranteed-node (cadr nodes))
		    (print-body (cddr nodes)))
		   ((and (list-node? (cadr nodes))
			 (fits-as-column? (node-subnodes (cadr nodes))
					  (+ new-optimistic 2)
					  0))
		    (*unparse-space)
		    (*unparse-open)
		    (print-guaranteed-column (node-subnodes (cadr nodes))
					     (+ new-optimistic 1))
		    (*unparse-close)
		    (print-body (cddr nodes)))
		   (else
		    (tab-to optimistic)
		    (print-node (cadr nodes) optimistic 0)
		    (print-body (cddr nodes))))))
	  (else
	   ;; ordinary let
	   (print-node (car nodes) optimistic 0)
	   (print-body (cdr nodes))))))

(define print-case-expression)
(define (kernel/print-case-expression nodes optimistic pessimistic depth)
  (define (print-cases nodes)
    (if (not (null? nodes))
	(begin
	  (tab-to pessimistic)
	  (print-column nodes pessimistic depth))))
  (cond ((null? (cdr nodes))
	 (print-node (car nodes) optimistic depth))
	((fits-within? (car nodes) optimistic 0)
	 (print-guaranteed-node (car nodes))
	 (print-cases (cdr nodes)))
	(else
	 (tab-to (+ pessimistic 2))
	 (print-node (car nodes) optimistic 0)
	 (print-cases (cdr nodes)))))

;;;; Alignment

(define-integrable (fits-within? node column depth)
  (> (- x-size depth)
     (+ column (node-size node))))

;;; Fits if each node fits when stacked vertically at the given column.

(define (fits-as-column? nodes column depth)
  (let loop ((nodes nodes))
    (if (null? (cdr nodes))
	(fits-within? (car nodes) column depth)
	(and (> x-size
		(+ column (node-size (car nodes))))
	     (loop (cdr nodes))))))

;;; Fits if first two nodes fit on same line, and rest fit under the
;;; second node.  Assumes at least two nodes are given.

(define (two-on-first-line? nodes column depth)
  (let ((column (+ column (+ 1 (node-size (car nodes))))))
    (and (> x-size column)
	 (fits-as-column? (cdr nodes) column depth))))

;;; Starts a new line with the specified indentation.

(define (tab-to column)
  (*unparse-newline)
  (pad-with-spaces column))

(define-integrable (pad-with-spaces n-spaces)
  (*unparse-string (make-string n-spaces #\space)))

;;;; Numerical Walk

(define (numerical-walk object list-depth)
  (define (numerical-walk-no-auto-highlight object list-depth)
    (cond ((pair? object)
	   (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))))))
	  ((symbol? object)
	   (if (or *pp-uninterned-symbols-by-name*
		   (interned-symbol? object))
	       object
	       (walk-custom unparse-object object list-depth)))
	  ((pretty-printer-highlight? object)
	   ;; (1) see note below.
	   (let ((rest (walk-highlighted-object
			object list-depth
			numerical-walk-no-auto-highlight)))
	     (make-highlighted-node (+ (pph/start-string-length object)
				       (pph/end-string-length object)
				       (node-size rest))
				    object
				    rest)))
	  ((vector? object)
	   (if (zero? (vector-length object))
	       (walk-custom unparse-object object list-depth)
	       (let ((unparser (unparse-vector/unparser object)))
		 (if unparser
		     (walk-custom unparser object list-depth)
		     (make-prefix-node "#"
				       (walk-pair (vector->list object)
						  list-depth))))))
	  ((primitive-procedure? object)
	   (if *pp-primitives-by-name*
	       (primitive-procedure-name object)
	       (walk-custom unparse-object object list-depth)))
	  (else
	   (walk-custom unparse-object object list-depth))))

  ;; We do the following test first and the test above at (1) for a
  ;; PRETTY-PRINTER-HIGHLIGHT because the highlighted object may
  ;; itself be a PRETTY-PRINTER-HIGHLIGHT.  It is also important that
  ;; the case (1) above uses NUMERICAL-WALK-NO-AUTO-HIGHLIGHT
  ;; otherwise we would get infinite recursion when the `unwrapped'
  ;; object REST is re-auto-highlighted by the test below.

  (cond ((and *pp-auto-highlighter*
	      (not (pretty-printer-highlight? object))
	      (*pp-auto-highlighter* object))
	 => (lambda (highlighted)
	      (numerical-walk-no-auto-highlight highlighted list-depth)))
	(else
	 (numerical-walk-no-auto-highlight object list-depth))))

(define (walk-custom unparser object list-depth)
  (call-with-output-string
   (lambda (port)
     (unparser (make-unparser-state port
				    list-depth
				    #t
				    (nearest-repl/environment))
	       object))))

(define (walk-pair pair list-depth)
  (if (and *unparser-list-depth-limit*
	   (>= list-depth *unparser-list-depth-limit*)
	   (no-highlights? pair))
      "..."
      (let ((list-depth (+ list-depth 1)))
	(let loop ((pair pair) (list-breadth 0))
	  (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
		  (numerical-walk (car pair) list-depth)))
		(else
		 (make-list-node
		  (numerical-walk (car pair) list-depth)
		  (let ((list-breadth (+ list-breadth 1)))
		    (if (and (pair? (cdr pair))
			     (not (unparse-list/unparser (cdr pair))))
			(loop (cdr pair) list-breadth)
			(make-list-node
			 "."
			 (make-singleton-list-node
			  (if (and *unparser-list-breadth-limit*
				   (>= list-breadth
				       *unparser-list-breadth-limit*)
				   (no-highlights? pair))
			      "..."
			      (numerical-walk (cdr pair)
					      list-depth)))))))))))))

(define-integrable (no-highlights? object)
  (or *pp-no-highlights?*
      (not (partially-highlighted? object))))

(define (partially-highlighted? object)
  (cond ((pair? object)
	 (or (partially-highlighted? (car object))
	     (partially-highlighted? (cdr object))))
	((pretty-printer-highlight? object)
	 #t)
	((vector? object)
	 (partially-highlighted? (vector->list object)))
	(else
	 #f)))

(define (walk-highlighted-object object list-depth numerical-walk)
  (let ((dl (pph/depth-limit object)))
    (fluid-let ((*unparser-list-breadth-limit*
		 (let ((bl (pph/breadth-limit object)))
		   (if (eq? bl 'DEFAULT)
		       *unparser-list-breadth-limit*
		       bl)))
		(*unparser-list-depth-limit*
		 (if (eq? dl 'DEFAULT)
		     *unparser-list-depth-limit*
		     dl)))
      (numerical-walk (pph/object object)
		      (if (eq? dl 'DEFAULT)
			  list-depth
			  0)))))


;;;     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,"
;;;  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.
;;;  This notation must be used because while a new parenthetical level is
;;;  generated for each car and each vector-ref, a new parenthetical level
;;;  obtains from cdring iff the result of said cdring is not a pair.

;; This is the master procedure which all circularity-proof printing
;; goes through.

(define (numerical-walk-avoid-circularities exp list-depth)
  (numerical-walk-terminating exp (cons exp (make-queue)) list-depth))

;; 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))
  (define half-pointer (car 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))
	       (let ((unparser (unparse-list/unparser object)))
		 (if unparser
		     (walk-custom unparser object list-depth)
		     (walk-pair-terminating object half-pointer/queue
					    list-depth))))))
	((symbol? object)
	 (if (or *pp-uninterned-symbols-by-name*
		 (interned-symbol? object))
	     object
	     (walk-custom unparse-object object list-depth)))
	((pretty-printer-highlight? object)
	 (let ((rest (walk-highlighted-object object list-depth)))
	   (make-highlighted-node (+ (pph/start-string-length object)
				     (pph/end-string-length object)
				     (node-size rest))
				  object
				  rest)))
	((vector? object)
	 (if (zero? (vector-length object))
	     (walk-custom unparse-object object list-depth)
	     (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))))))
	((primitive-procedure? object)
	 (if *pp-primitives-by-name*
	     (primitive-procedure-name object)
	     (walk-custom unparse-object object list-depth)))
	(else
	 (walk-custom unparse-object object list-depth))))

;;; The following two procedures walk lists and vectors, respectively.

(define (walk-pair-terminating pair half-pointer/queue list-depth)
	(if (and *unparser-list-depth-limit*
	   (>= list-depth *unparser-list-depth-limit*)
	   (no-highlights? pair))
      "..."
      (let ((list-depth (+ list-depth 1)))
	(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)))))
		    (if (eq? (car half-pointer/queue) (car pair))
			(circularity-string (cdr half-pointer/queue))
			(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)))))
		    (if (eq? (car half-pointer/queue) (car pair))
			(circularity-string (cdr half-pointer/queue))
			(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 (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)))))))))))))))

(define (walk-vector-terminating pair half-pointer/queue list-depth)
  (if (and *unparser-list-depth-limit*
	   (>= list-depth *unparser-list-depth-limit*)
	   (no-highlights? pair))
      "..."
      (let ((list-depth (+ list-depth 1)))
	(let loop ((pair pair) (list-breadth 0))
	  (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) (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)))))
		(else
		 (make-list-node
		  (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)))
		  (let ((list-breadth (+ list-breadth 1)))
		    (if (not (unparse-list/unparser (cdr pair)))
			(loop (cdr pair) list-breadth)
			(make-list-node
			 "."
			 (make-singleton-list-node
			  (if (and *unparser-list-breadth-limit*
				   (>= list-breadth
				       *unparser-list-breadth-limit*)
				   (no-highlights? pair))
			      "..."
			      (numerical-walk-terminating
			       (cdr pair)
			       half-pointer/queue list-depth)))))))))))))

;;;; These procedures allow the walkers to interact with the queue.

(define cocked-object)

(define (advance half-object queue)
  (cond ((vector? half-object)
	 (cons (cons cocked-object half-object) queue))
	((not (pair? half-object))
	 (cons half-object queue))
	((eq? (car half-object) cocked-object)
	 (cons (let ((directive (queue-car queue)))
		 (cond ((>= directive 0)
			(vector-ref (cdr half-object) directive))
		       ((= directive -1)
			(cadr half-object))
		       (else
			(cddr half-object))))
	       (queue-cdr queue)))
	(else
	 (cons (cons cocked-object half-object) queue))))

(define (update-queue queue command-list)
  (define (uq-iter queue command-list)
    (cond ((null? command-list) queue)
	  ((eq? (car command-list) 'CAR)
	   (uq-iter (add-car queue) (cdr command-list)))
	  ((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 queue command-list))

(define (add-car queue)
  (queue-cons queue -1))

(define (add-cdr queue)
  (queue-cons queue -2))

(define (add-vector-ref n queue)
  (queue-cons queue n))


;;;; The Queue Abstraction.  Queues are data structures allowing fifo
;;;  access without mutation.  The following procedures implement them.

(define-structure (queue
		   (conc-name queue/)
		   (constructor
		    make-queue
		    (#!optional cons-cell past-cdrs)))
  (cons-cell (let* ((new-vector (make-fluid-vector))
		    (pointer (cons 0 new-vector)))
	       (cons pointer pointer)))
  (past-cdrs 0))

;;; Fluid Vectors.
;;  Queues are built on a subabstraction, "fluid-vectors," which
;;  are actually nested vectors of a default length.

(define default-fluid-vector-length 10)
(define virtual-fluid-vector-length (-1+ default-fluid-vector-length))

(define (fluid-vector-extend fluid-vector)
  (define new-fluid-vector (make-fluid-vector))
  (vector-set! fluid-vector virtual-fluid-vector-length new-fluid-vector)
  new-fluid-vector)

(define (fluid-vector-set! fluid-vector index object)
  (define tail (vector-ref fluid-vector virtual-fluid-vector-length))
  (if (< index virtual-fluid-vector-length)
      (vector-set! fluid-vector index object)
      (fluid-vector-set! tail (- index virtual-fluid-vector-length) object)))

(define (make-fluid-vector)
  (make-vector default-fluid-vector-length #f))

;;; The actual queue constructors/extractors

(define (queue-cons queue object)
  (let* ((old-cell (queue/cons-cell queue))
	 (head (car old-cell))
	 (tail (cdr old-cell)))
    (if (eq? head tail)
	(begin
	  (fluid-vector-set! (cdr tail) 0 object)
	  (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))
				(cons 0 (fluid-vector-extend (cdr tail)))
				(cons (1+ (car tail)) (cdr tail))))
		      (queue/past-cdrs queue))))))

(define (queue-car queue)
  (define head (car (queue/cons-cell queue)))
  (vector-ref (cdr head) (car head)))

(define (queue-cdr queue)
  (define head (car (queue/cons-cell queue)))
  (define tail (cdr (queue/cons-cell queue)))
  (make-queue
   (cons
    (if (= (car head) (-1+ virtual-fluid-vector-length))
	(cons 0 (vector-ref (cdr head) virtual-fluid-vector-length))
	(cons (1+ (car head)) (cdr head)))
    tail)
   (if (= (queue-car queue) -2)
       (1+ (queue/past-cdrs queue))
       0)))

;;; Auxilary queue handlers.

(define (null-queue? queue)
  (define cell (queue/cons-cell queue))
  (eq? (car cell) (cdr cell)))

(define (queue-depth 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))))
  (define (proc-list-iter list code-cache)
    (cond ((null? list) (if (eq? code-cache -2) 1 0))
	  ((>= (car list) 0)
	   (+ (if (eq? code-cache -2) 2 1)
	      (proc-list-iter (cdr list) (car list))))
	  ((= (car list) -1)
	   (1+ (proc-list-iter (cdr list) (car list))))
	  (else
	   (proc-list-iter (cdr list) (car list)))))
  (let* ((cell (queue/cons-cell queue))
	 (head (car cell))
	 (tail (cdr cell))
	 (operating-list
	  (flatten (cdr head) (car head) (cdr tail) (car tail))))
    (proc-list-iter operating-list #f)))


;;; This procedure creates the circularity object which is printed
;;; within circular structures.

(define (circularity-string queue)
  (let ((depth (queue-depth queue))
	(cdrs (queue/past-cdrs queue)))
    (string-append
     (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")))
     (cond ((= cdrs 0) ")]")
	   ((= cdrs 1) ", downstream 1 cdr.)]")
	   (else
	    (string-append ", downstream "
			   (number->string cdrs) " cdrs.)]"))))))


;;;; Node Model
;;;  Carefully crafted to use the least amount of memory, while at the
;;;  same time being as fast as possible.  The only concession to
;;;  space was in the implementation of atomic nodes, in which it was
;;;  decided that the extra space needed to cache the size of a string
;;;  or the print-name of a symbol wasn't worth the speed that would
;;;  be gained by keeping it around.

(define (symbol-length symbol)
  (string-length
   (call-with-output-string
     (lambda (port)
       (write symbol port)))))

(define (*unparse-symbol symbol)
  (write symbol output-port))

(define-structure (prefix-node
		   (conc-name prefix-node-)
		   (constructor %make-prefix-node))
  (size #f read-only #t)
  (prefix #f read-only #t)
  (subnode #f read-only #t))

(define (make-prefix-node prefix subnode)
  (cond ((string? subnode)
	 (string-append prefix subnode))
	((prefix-node? subnode)
	 (make-prefix-node (string-append prefix (prefix-node-prefix subnode))
			   (prefix-node-subnode subnode)))
	(else
	 (%make-prefix-node (+ (string-length prefix) (node-size subnode))
			    prefix
			    subnode))))


(define (make-list-node car-node cdr-node)
  (cons (+ 1 (node-size car-node) (list-node-size cdr-node)) ;+1 space.
	(cons car-node (node-subnodes cdr-node))))

(define (make-singleton-list-node car-node)
  (cons (+ 2 (node-size car-node))			;+1 each parenthesis.
	(list car-node)))

(define-integrable (list-node? object)
  (pair? object))

(define-integrable (list-node-size node)
  (car node))

(define-integrable (node-subnodes node)
  (cdr node))

(define (node-size node)
  (cond ((list-node? node) (list-node-size node))
	((symbol? node) (symbol-length node))
	((prefix-node? node) (prefix-node-size node))
	((highlighted-node? node)
	 (highlighted-node/size node))
	(else (string-length node))))

(define-structure (highlighted-node
		   (conc-name highlighted-node/)
		   (constructor make-highlighted-node))
  (size #f read-only #t)
  (highlight #f read-only #t)
  (subnode #f read-only #t))

(define (unhighlight node)
  (if (highlighted-node? node)
      (unhighlight (highlighted-node/subnode node))
      node))