From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Fri, 16 Aug 1991 01:21:21 +0000 (+0000)
Subject: Update pretty printer to include highlight objects, tabulation of data
X-Git-Tag: 20090517-FFI~10360
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6ad163ca5bc2b7baa32713671e83621ba3f27cb2;p=mit-scheme.git

Update pretty printer to include highlight objects, tabulation of data
lists, better user control by means of exported variables, and more
consistent modes (data versus code).
---

diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm
index 5f9699525..f77016d08 100644
--- a/v7/src/runtime/pp.scm
+++ b/v7/src/runtime/pp.scm
@@ -1,8 +1,8 @@
 #| -*-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
@@ -42,7 +42,7 @@ MIT in each case. |#
   (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)
@@ -52,13 +52,32 @@ MIT in each case. |#
 	  (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)))
@@ -77,24 +96,28 @@ MIT in each case. |#
 	       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))
 
 (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)
@@ -127,7 +150,15 @@ MIT in each case. |#
 
 (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)
@@ -135,36 +166,81 @@ MIT in each case. |#
   (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))))
 
@@ -195,6 +271,81 @@ MIT in each case. |#
 	  (tab-to column)
 	  (loop (cdr nodes))))))
 
+(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))
+
 ;;;; Printers
 
 (define (print-combination nodes column depth)
@@ -214,6 +365,7 @@ MIT in each case. |#
 
 (define dispatch-list)
 (define dispatch-default)
+(define code-dispatch-list)
 
 (define ((special-printer procedure) nodes column depth)
   (*unparse-open)
@@ -253,8 +405,11 @@ MIT in each case. |#
 (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
@@ -330,7 +485,10 @@ MIT in each case. |#
 
 (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)))
 
 ;;;; Numerical Walk
 
@@ -345,6 +503,21 @@ MIT in each case. |#
 		 (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)
@@ -354,11 +527,6 @@ MIT in each case. |#
 		   (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)
@@ -377,12 +545,14 @@ MIT in each case. |#
 
 (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
@@ -399,10 +569,42 @@ MIT in each case. |#
 			 (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)))))
 
 ;;;; Node Model
 ;;;  Carefully crafted to use the least amount of memory, while at the
@@ -412,36 +614,34 @@ MIT in each case. |#
 ;;;  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))))
@@ -463,4 +663,13 @@ MIT in each case. |#
   (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
diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 241963315..c152cd5f9 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.131 1991/08/14 02:09:12 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.132 1991/08/16 01:21:21 jinx Exp $
 
 Copyright (c) 1988-91 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 131))
+  (add-identification! "Runtime" 14 132))
 
 (define microcode-system)