#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.13 1990/09/27 03:33:02 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.14 1991/08/16 01:20:47 jinx Exp $
-Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(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! dispatch-list
+ (set! code-dispatch-list
`((COND . ,forced-indentation)
(IF . ,forced-indentation)
(OR . ,forced-indentation)
(DEFINE . ,print-procedure)
(LAMBDA . ,print-procedure)
(NAMED-LAMBDA . ,print-procedure)))
+ (set! dispatch-list code-dispatch-list)
(set! dispatch-default print-combination)
unspecific)
-(define *named-lambda->define?* true)
+(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 false read-only true)
+ (start-string "*=>" read-only true)
+ (end-string "<=*" read-only true)
+ (as-code? 'DEFAULT read-only true)
+ (depth-limit 'DEFAULT read-only true)
+ (breadth-limit 'DEFAULT read-only true))
+
+(define *pp-named-lambda->define?* true)
(define *pp-primitives-by-name* true)
(define *pp-uninterned-symbols-by-name* true)
-(define *forced-x-size* false)
+(define *pp-no-highlights?* true)
+(define *pp-really-pretty?* true)
+(define *pp-lists-as-tables?* true)
+(define *pp-forced-x-size* false)
(define (pp object #!optional port . rest)
(let ((port (if (default-object? port) (current-output-port) port)))
object))))))
(define (pretty-print object #!optional port as-code? indentation)
- (pp-top-level (if (scode-constant? object)
- object
- (let ((sexp (unsyntax object)))
- (if (and *named-lambda->define?*
- (pair? sexp)
- (eq? (car sexp) 'NAMED-LAMBDA))
- `(DEFINE ,@(cdr sexp))
- sexp)))
- (if (default-object? port) (current-output-port) port)
- (if (default-object? as-code?)
- (not (scode-constant? object))
- as-code?)
- (if (default-object? indentation) 0 indentation)
- 0)
- unspecific)
+ (let ((as-code?
+ (if (default-object? as-code?)
+ (not (scode-constant? object))
+ as-code?)))
+ (pp-top-level (let ((sexp
+ (if (scode-constant? object)
+ object
+ (unsyntax object))))
+ (if (and as-code?
+ (pair? sexp)
+ *pp-named-lambda->define?*
+ (eq? (car sexp) 'NAMED-LAMBDA))
+ `(DEFINE ,@(cdr sexp))
+ sexp))
+ (if (default-object? port) (current-output-port) port)
+ as-code?
+ (if (default-object? indentation) 0 indentation)
+ 0)
+ unspecific))
\f
(define (pp-top-level expression port as-code? indentation list-depth)
- (fluid-let ((x-size (or *forced-x-size* (output-port/x-size port)))
+ (fluid-let ((x-size (or *pp-forced-x-size* (output-port/x-size port)))
(output-port port))
(let ((node (numerical-walk expression list-depth)))
(if (positive? indentation)
\f
(define (print-non-code-node node column depth)
(fluid-let ((dispatch-list '())
- (dispatch-default print-data-column))
+ (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)
(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 (node-prefix node))
- (print-node (node-subnode node)
- (+ column (string-length (node-prefix node)))
- depth))
+ (*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)))
+ (let ((start-string (pph/start-string highlight))
+ (end-string (pph/end-string highlight)))
+ (*unparse-string start-string)
+ (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)))))
+ (fluid-let ((x-size
+ (let ((value (- x-size (string-length end-string))))
+ (if (not (positive? value))
+ x-size
+ value))))
+ (handler (highlighted-node/subnode node)
+ (+ column (string-length start-string))
+ depth)))
+ (*unparse-string end-string))))
(else
(*unparse-string node))))
(define (print-list-node node column depth)
- (if (fits-within? node column depth)
+ (if (and (not *pp-really-pretty?*)
+ (fits-within? node column depth))
(print-guaranteed-list-node node)
- (let ((subnodes (node-subnodes node)))
- ((or (let ((association (assq (car subnodes) dispatch-list)))
- (and association (cdr association)))
- dispatch-default)
- subnodes column depth))))
+ (let* ((subnodes (node-subnodes node))
+ (association
+ (and (not (null? (cdr subnodes)))
+ (assq (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)
+ (let ((start-string (pph/start-string (highlighted-node/highlight node)))
+ (end-string (pph/end-string (highlighted-node/highlight node))))
+ (*unparse-string start-string)
+ (print-guaranteed-node (highlighted-node/subnode node))
+ (*unparse-string end-string)))
((prefix-node? node)
- (*unparse-string (node-prefix node))
- (print-guaranteed-node (node-subnode node)))
+ (*unparse-string (prefix-node-prefix node))
+ (print-guaranteed-node (prefix-node-subnode node)))
(else
(*unparse-string node))))
(tab-to column)
(loop (cdr nodes))))))
\f
+(define (maybe-print-table nodes column depth)
+ (define (default)
+ (print-columns nodes column depth))
+
+ (let ((available-space (-1+ (- x-size column))))
+
+ (define (try-columns n-columns)
+ (let* ((nodev (list->vector nodes))
+ (vsize (vector-length nodev)))
+
+ (define (fit? widths space)
+ (or (null? widths)
+ (let ((next (- space (1+ (car widths)))))
+ (and (>= next 0)
+ (fit? (cdr widths)
+ next)))))
+
+ (define (find-max-width posn step)
+ (let loop ((posn posn)
+ (width 0))
+ (if (>= posn vsize)
+ 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 (fit? widths available-space)
+ (print-table nodes column widths)
+ (try (- n 1))))))
+
+ (try n-columns)))
+
+ (let loop ((n 1)
+ (nodes (cdr nodes))
+ (space (- available-space
+ (node-size (car nodes)))))
+ (cond ((> space 0)
+ (loop (1+ n)
+ (cdr nodes)
+ (- space (1+ (node-size (car nodes))))))
+ ((<= n 2)
+ (default))
+ (else
+ (try-columns (-1+ n)))))))
+
+(define (print-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))
+\f
;;;; Printers
(define (print-combination nodes column depth)
(define dispatch-list)
(define dispatch-default)
+(define code-dispatch-list)
(define ((special-printer procedure) nodes column depth)
(*unparse-open)
(define print-procedure)
(define (kernel/print-procedure nodes optimistic pessimistic depth)
(print-node (car nodes) optimistic 0)
- (tab-to pessimistic)
- (print-column (cdr nodes) pessimistic depth))
+ (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
(define (tab-to column)
(*unparse-newline)
- (*unparse-string (make-string column #\space)))
+ (pad-with-spaces column))
+
+(define-integrable (pad-with-spaces n-spaces)
+ (*unparse-string (make-string n-spaces #\space)))
\f
;;;; Numerical Walk
(if unparser
(walk-custom unparser object list-depth)
(walk-pair object list-depth))))))
+ ((symbol? object)
+ (if (or *pp-uninterned-symbols-by-name*
+ (object-type? (ucode-type interned-symbol) object))
+ object
+ (walk-custom unparse-object object list-depth)))
+ ((pretty-printer-highlight? object)
+ (let ((rest (walk-highlighted-object object list-depth))
+ (start (pph/start-string object))
+ (end (pph/end-string object)))
+ (make-highlighted-node
+ (+ (string-length start)
+ (string-length end)
+ (node-size rest))
+ object
+ rest)))
((vector? object)
(if (zero? (vector-length object))
(walk-custom unparse-object object list-depth)
(make-prefix-node "#"
(walk-pair (vector->list object)
list-depth))))))
- ((symbol? object)
- (if (or *pp-uninterned-symbols-by-name*
- (object-type? (ucode-type interned-symbol) object))
- object
- (walk-custom unparse-object object list-depth)))
((primitive-procedure? object)
(if *pp-primitives-by-name*
(primitive-procedure-name object)
(define (walk-pair pair list-depth)
(if (and *unparser-list-depth-limit*
- (>= list-depth *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*))
+ (>= list-breadth *unparser-list-breadth-limit*)
+ (no-highlights? pair))
(make-singleton-list-node "..."))
((null? (cdr pair))
(make-singleton-list-node
(make-singleton-list-node
(if (and *unparser-list-breadth-limit*
(>= list-breadth
- *unparser-list-breadth-limit*))
+ *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)
+ true)
+ ((vector? object)
+ (partially-highlighted? (vector->list object)))
+ (else
+ false)))
+
+(define (walk-highlighted-object object list-depth)
+ (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)))))
\f
;;;; Node Model
;;; Carefully crafted to use the least amount of memory, while at the
;;; or the print-name of a symbol wasn't worth the speed that would
;;; be gained by keeping it around.
+(define-integrable (%symbol->string symbol)
+ (system-pair-car symbol))
+
(define-integrable (symbol-length symbol)
- (string-length (symbol->string symbol)))
+ (string-length (%symbol->string symbol)))
(define-integrable (*unparse-symbol symbol)
- (*unparse-string (symbol->string symbol)))
+ (*unparse-string (%symbol->string symbol)))
+
+(define-structure (prefix-node
+ (conc-name prefix-node-)
+ (constructor %make-prefix-node))
+ (size false read-only true)
+ (prefix false read-only true)
+ (subnode false read-only true))
(define (make-prefix-node prefix subnode)
(cond ((or (list-node? subnode)
(symbol? subnode))
- (vector (+ (string-length prefix) (node-size subnode))
- prefix
- subnode))
+ (%make-prefix-node (+ (string-length prefix) (node-size subnode))
+ prefix
+ subnode))
((prefix-node? subnode)
- (make-prefix-node (string-append prefix (node-prefix subnode))
- (node-subnode subnode)))
+ (make-prefix-node (string-append prefix (prefix-node-prefix subnode))
+ (prefix-node-subnode subnode)))
(else
(string-append prefix subnode))))
-(define-integrable (prefix-node? object)
- (vector? object))
-
-(define-integrable (prefix-node-size node)
- (vector-ref node 0))
-
-(define-integrable (node-prefix node)
- (vector-ref node 1))
-
-(define-integrable (node-subnode node)
- (vector-ref node 2))
-
(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))))
(cond ((list-node? node) (list-node-size node))
((symbol? node) (symbol-length node))
((prefix-node? node) (prefix-node-size node))
- (else (string-length node))))
\ No newline at end of file
+ ((highlighted-node? node)
+ (highlighted-node/size node))
+ (else (string-length node))))
+
+(define-structure (highlighted-node
+ (conc-name highlighted-node/)
+ (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
projects / mit-scheme.git / commitdiff