From c86e430e09808a0432b3f658beb90940d1f4c198 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Fri, 6 Dec 1991 05:23:17 +0000
Subject: [PATCH] Changed the dispatch for cons to pprint-fill and added a
 dispatch for (cons symbol) to pprint-function-call.  This way the results of
 (list-all-packages) won't show up as a function call.

Added TAB support.
---
 code/pprint.lisp | 181 +++++++++++++++++++++++++++++++++++++----------
 1 file changed, 143 insertions(+), 38 deletions(-)

diff --git a/code/pprint.lisp b/code/pprint.lisp
index 2fb61be16..3652426f2 100644
--- a/code/pprint.lisp
+++ b/code/pprint.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.4 1991/12/05 05:09:06 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.5 1991/12/06 05:23:17 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -121,9 +121,7 @@
 	  (kernel:get-lisp-obj-address pstream)))
 
 
-(declaim (inline index-position position-index
-		 index-column column-index
-		 position-column))
+(declaim (inline index-position position-index position-column))
 (defun index-position (index stream)
   (declare (type index index) (type pretty-stream stream)
 	   (values position))
@@ -132,14 +130,6 @@
   (declare (type position position) (type pretty-stream stream)
 	   (values index))
   (- position (pretty-stream-buffer-offset stream)))
-(defun index-column (index stream)
-  (declare (type index index) (type pretty-stream stream)
-	   (values column))
-  (+ index (pretty-stream-buffer-start-column stream)))
-(defun column-index (column stream)
-  (declare (type column column) (type pretty-stream stream)
-	   (values index))
-  (- column (pretty-stream-buffer-start-column stream)))
 (defun position-column (position stream)
   (declare (type position position) (type pretty-stream stream)
 	   (values position))
@@ -202,6 +192,9 @@
   ;; The column this logical block started in.
   (start-column 0 :type column)
   ;;
+  ;; The column the current section started in.
+  (section-column 0 :type column)
+  ;;
   ;; The length of the per-line prefix.  We can't move the indentation
   ;; left of this.
   (per-line-prefix-end 0 :type index)
@@ -223,6 +216,7 @@
 	 (suffix-length (logical-block-suffix-length prev-block))
 	 (block (make-logical-block
 		 :start-column column
+		 :section-column column
 		 :per-line-prefix-end per-line-end
 		 :prefix-length prefix-length
 		 :suffix-length suffix-length
@@ -331,8 +325,7 @@
 		 (null (section-start-section-end entry))
 		 (<= depth (section-start-depth entry)))
 	(setf (section-start-section-end entry) newline))))
-  (when (or (eq kind :literal) (eq kind :mandatory))
-    (do-some-output stream t)))
+  (maybe-output stream (or (eq kind :literal) (eq kind :mandatory))))
 
 (defstruct (indentation
 	    (:include queued-op))
@@ -371,10 +364,113 @@
       (pretty-sout stream suffix 0 (length suffix)))
     (setf (block-start-block-end start) end)))
 
+(defstruct (tab
+	    (:include queued-op))
+  (sectionp nil :type (member t nil))
+  (relativep nil :type (member t nil))
+  (colnum 0 :type column)
+  (colinc 0 :type column))
+
 (defun enqueue-tab (stream kind colnum colinc)
-  ;; ### Need to figure this out.
-  (declare (ignore stream kind colnum colinc)))
+  (multiple-value-bind
+      (sectionp relativep)
+      (ecase kind
+	(:line (values nil nil))
+	(:line-relative (values nil t))
+	(:section (values t nil))
+	(:section-relative (values t t)))
+    (enqueue stream tab :sectionp sectionp :relativep relativep
+	     :colnum colnum :colinc colinc)))
 
+
+;;;; Tab support.
+
+(defun compute-tab-size (tab section-start column)
+  (let ((origin (if (tab-sectionp tab) section-start 0))
+	(colnum (tab-colnum tab))
+	(colinc (tab-colinc tab)))
+    (cond ((tab-relativep tab)
+	   (unless (<= colinc 1)
+	     (let ((newposn (+ column colnum)))
+	       (let ((rem (rem newposn colinc)))
+		 (unless (zerop rem)
+		   (incf colnum (- colinc rem))))))
+	   colnum)
+	  ((<= column (+ colnum origin))
+	   (- (+ colnum origin) column))
+	  (t
+	   (- colinc
+	      (rem (- column origin) colinc))))))
+
+(defun index-column (index stream)
+  (let ((column (pretty-stream-buffer-start-column stream))
+	(section-start (logical-block-section-column
+			(first (pretty-stream-blocks stream))))
+	(end-position (index-position index stream)))
+    (dolist (op (pretty-stream-queue-tail stream))
+      (when (>= (queued-op-position op) end-position)
+	(return))
+      (typecase op
+	(tab
+	 (incf column
+	       (compute-tab-size op
+				 section-start
+				 (+ column
+				    (position-index (tab-position op)
+						    stream)))))
+	((or newline block-start)
+	 (setf section-start
+	       (+ column (position-index (queued-op-position op)
+					 stream))))))
+    (+ column index)))
+
+(defun expand-tabs (stream through)
+  (let ((insertions nil)
+	(additional 0)
+	(column (pretty-stream-buffer-start-column stream))
+	(section-start (logical-block-section-column
+			(first (pretty-stream-blocks stream)))))
+    (dolist (op (pretty-stream-queue-tail stream))
+      (typecase op
+	(tab
+	 (let* ((index (position-index (tab-position op) stream))
+		(tabsize (compute-tab-size op
+					   section-start
+					   (+ column index))))
+	   (unless (zerop tabsize)
+	     (push (cons index tabsize) insertions)
+	     (incf additional tabsize)
+	     (incf column tabsize))))
+	((or newline block-start)
+	 (setf section-start
+	       (+ column (position-index (queued-op-position op) stream)))))
+      (when (eq op through)
+	(return)))
+    (when insertions
+      (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+	     (new-fill-ptr (+ fill-ptr additional))
+	     (buffer (pretty-stream-buffer stream))
+	     (new-buffer buffer)
+	     (length (length buffer))
+	     (end fill-ptr))
+	(when (> new-fill-ptr length)
+	  (let ((new-length (max (* length 2)
+				 (+ fill-ptr
+				    (floor (* additional 5) 4)))))
+	    (setf new-buffer (make-string new-length))
+	    (setf (pretty-stream-buffer stream) new-buffer)))
+	(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+	(decf (pretty-stream-buffer-offset stream) additional)
+	(dolist (insertion insertions)
+	  (let* ((srcpos (car insertion))
+		 (amount (cdr insertion))
+		 (dstpos (+ srcpos additional)))
+	    (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end)
+	    (fill new-buffer #\space :start srcpos :end dstpos)
+	    (decf additional amount)
+	    (setf end srcpos)))
+	(unless (eq new-buffer buffer)
+	  (replace new-buffer buffer :end1 end :end2 end))))))
 
 
 ;;;; Stuff to do the actual outputting.
@@ -389,7 +485,8 @@
     (cond ((plusp available)
 	   available)
 	  ((> fill-ptr (pretty-stream-line-length stream))
-	   (do-some-output stream nil)
+	   (unless (maybe-output stream nil)
+	     (output-partial-line stream))
 	   (assure-space-in-buffer stream want))
 	  (t
 	   (let* ((new-length (max (* length 2)
@@ -400,9 +497,10 @@
 	     (replace new-buffer buffer :end1 fill-ptr)
 	     (- new-length fill-ptr))))))
 
-(defun do-some-output (stream force-newlines-p)
+(defun maybe-output (stream force-newlines-p)
   (declare (type pretty-stream stream))
-  (let ((tail (pretty-stream-queue-tail stream)))
+  (let ((tail (pretty-stream-queue-tail stream))
+	(output-anything nil))
     (loop
       (unless tail
 	(setf (pretty-stream-queue-head stream) nil)
@@ -425,6 +523,7 @@
 			  ((nil) t)
 			  (:dont-know
 			   (return))))))
+	     (setf output-anything t)
 	     (output-line stream next)))
 	  (indentation
 	   (unless (misering-p stream)
@@ -444,7 +543,9 @@
 	     ((t)
 	      ;; Just nuke the whole logical block and make it look like one
 	      ;; nice long literal.
-	      (setf tail (cdr (member (block-start-block-end next) tail))))
+	      (let ((end (block-start-block-end next)))
+		(expand-tabs stream end)
+		(setf tail (cdr (member end tail)))))
 	     ((nil)
 	      (really-start-logical-block
 	       stream
@@ -454,11 +555,11 @@
 	     (:dont-know
 	      (return))))
 	  (block-end
-	   (really-end-logical-block stream))))
-      (setf (pretty-stream-queue-tail stream) tail)))
-  (when (> (pretty-stream-buffer-fill-pointer stream)
-	   (pretty-stream-line-length stream))
-    (output-partial-line stream)))
+	   (really-end-logical-block stream))
+	  (tab
+	   (expand-tabs stream next))))
+      (setf (pretty-stream-queue-tail stream) tail))
+    output-anything))
 
 (defun misering-p (stream)
   (declare (type pretty-stream stream))
@@ -518,7 +619,7 @@
       (write-char #\newline target)
       (setf (pretty-stream-buffer-start-column stream) 0)
       (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
-	     (block (car (pretty-stream-blocks stream)))
+	     (block (first (pretty-stream-blocks stream)))
 	     (prefix-len
 	      (if literal-p
 		  (logical-block-per-line-prefix-end block)
@@ -529,19 +630,22 @@
 	(replace buffer (pretty-stream-prefix stream)
 		 :end1 prefix-len)
 	(setf (pretty-stream-buffer-fill-pointer stream) (- fill-ptr shift))
-	(incf (pretty-stream-buffer-offset stream) shift))
-      (unless literal-p
-	(setf (logical-block-section-start-line
-	       (first (pretty-stream-blocks stream)))
-	      line-number)))))
+	(incf (pretty-stream-buffer-offset stream) shift)
+	(unless literal-p
+	  (setf (logical-block-section-column block) prefix-len)
+	  (setf (logical-block-section-start-line block) line-number))))))
 
 (defun output-partial-line (stream)
   (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
-	 (count (column-index (- (index-column fill-ptr stream)
-				 (pretty-stream-line-length stream))
-			      stream))
+	 (tail (pretty-stream-queue-tail stream))
+	 (count
+	  (if tail
+	      (position-index (queued-op-position (car tail)) stream)
+	      fill-ptr))
 	 (new-fill-ptr (- fill-ptr count))
 	 (buffer (pretty-stream-buffer stream)))
+    (when (zerop count)
+      (error "Output-partial-line called when nothing can be output."))
     (write-string buffer (pretty-stream-target stream)
 		  :start 0 :end count)
     (incf (pretty-stream-buffer-start-column stream) count)
@@ -550,7 +654,7 @@
     (incf (pretty-stream-buffer-offset stream) count)))
 
 (defun force-pretty-output (stream)
-  (do-some-output stream nil)
+  (maybe-output stream nil)
   (write-string (pretty-stream-buffer stream)
 		(pretty-stream-target stream)
 		:end (pretty-stream-buffer-fill-pointer stream)))
@@ -1201,7 +1305,7 @@
 
 (defun pprint-do (stream list &rest noise)
   (declare (ignore noise))
-  (pprint-logical-block (stream list)
+  (pprint-logical-block (stream list :prefix "(" :suffix ")")
     (pprint-exit-if-list-exhausted)
     (output-object (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)
@@ -1218,7 +1322,7 @@
 
 (defun pprint-dolist (stream list &rest noise)
   (declare (ignore noise))
-  (pprint-logical-block (stream list)
+  (pprint-logical-block (stream list :prefix "(" :suffix ")")
     (pprint-exit-if-list-exhausted)
     (output-object (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)
@@ -1360,7 +1464,8 @@
 	(*building-initial-table* t))
     ;; Printers for regular types.
     (set-pprint-dispatch 'array #'pprint-array)
-    (set-pprint-dispatch 'cons #'pprint-function-call -1)
+    (set-pprint-dispatch '(cons symbol) #'pprint-function-call -1)
+    (set-pprint-dispatch 'cons #'pprint-fill -2)
     ;; Cons cells with interesting things for the car.
     (dolist (magic-form magic-forms)
       (set-pprint-dispatch `(cons (eql ,(first magic-form)))
-- 
GitLab