Skip to content
Snippets Groups Projects
Commit ffebdd15 authored by wlott's avatar wlott
Browse files

Actually store the change in the suffix length in the pretty-stream

structure (was causing suffixes to be ignored with line abbrevs).
Fixed an off-by-one error in desciding when to use line abbrevs.
Fixed output-line to make sure the buffer is large enough to fit
the prefix before we copy it in.
Added several new keywords to pprint-logical-block as per my proposed
cleanup.
Changed pprint-function-call to put a fill-style newline between the
the function and the first arg instead of a miser style newline.
parent d3eb84b8
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.5 1991/12/06 05:23:17 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.6 1991/12/13 06:06:44 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -246,7 +246,7 @@ ...@@ -246,7 +246,7 @@
(replace total-suffix suffix (replace total-suffix suffix
:start1 (- total-suffix-len new-suffix-len) :start1 (- total-suffix-len new-suffix-len)
:end1 (- total-suffix-len suffix-length)) :end1 (- total-suffix-len suffix-length))
(setf suffix-length new-suffix-len)))) (setf (logical-block-suffix-length block) new-suffix-len))))
nil) nil)
(defun set-indentation (stream column) (defun set-indentation (stream column)
...@@ -603,6 +603,7 @@ ...@@ -603,6 +603,7 @@
0))))) 0)))))
(write-string buffer target :end amount-to-print) (write-string buffer target :end amount-to-print)
(let ((line-number (pretty-stream-line-number stream))) (let ((line-number (pretty-stream-line-number stream)))
(incf line-number)
(when (and *print-lines* (>= line-number *print-lines*)) (when (and *print-lines* (>= line-number *print-lines*))
(write-string " .." target) (write-string " .." target)
(let ((suffix-length (logical-block-suffix-length (let ((suffix-length (logical-block-suffix-length
...@@ -614,7 +615,6 @@ ...@@ -614,7 +615,6 @@
:start (- len suffix-length) :start (- len suffix-length)
:end len)))) :end len))))
(throw 'line-limit-abbreviation-happened t)) (throw 'line-limit-abbreviation-happened t))
(incf line-number)
(setf (pretty-stream-line-number stream) line-number) (setf (pretty-stream-line-number stream) line-number)
(write-char #\newline target) (write-char #\newline target)
(setf (pretty-stream-buffer-start-column stream) 0) (setf (pretty-stream-buffer-start-column stream) 0)
...@@ -624,12 +624,23 @@ ...@@ -624,12 +624,23 @@
(if literal-p (if literal-p
(logical-block-per-line-prefix-end block) (logical-block-per-line-prefix-end block)
(logical-block-prefix-length block))) (logical-block-prefix-length block)))
(shift (- amount-to-consume prefix-len))) (shift (- amount-to-consume prefix-len))
(replace buffer buffer (new-fill-ptr (- fill-ptr shift))
(new-buffer buffer)
(buffer-length (length buffer)))
(when (> new-fill-ptr buffer-length)
(setf new-buffer
(make-string (max (* buffer-length 2)
(+ buffer-length
(floor (* (- new-fill-ptr buffer-length)
5)
4)))))
(setf (pretty-stream-buffer stream) new-buffer))
(replace new-buffer buffer
:start1 prefix-len :start2 amount-to-consume :end2 fill-ptr) :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
(replace buffer (pretty-stream-prefix stream) (replace new-buffer (pretty-stream-prefix stream)
:end1 prefix-len) :end1 prefix-len)
(setf (pretty-stream-buffer-fill-pointer stream) (- fill-ptr shift)) (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
(incf (pretty-stream-buffer-offset stream) shift) (incf (pretty-stream-buffer-offset stream) shift)
(unless literal-p (unless literal-p
(setf (logical-block-section-column block) prefix-len) (setf (logical-block-section-column block) prefix-len)
...@@ -676,13 +687,13 @@ ...@@ -676,13 +687,13 @@
#'(lambda (,stream-var) #'(lambda (,stream-var)
,@body))) ,@body)))
;;;; User interface to the pretty printer. ;;;; User interface to the pretty printer.
(defmacro pprint-logical-block (defmacro pprint-logical-block
((stream-symbol list &key prefix per-line-prefix suffix) ((stream-symbol object &key prefix per-line-prefix suffix
allow-atoms (descend t) (check-for-circularity t)
(initiate-pretty-printing t))
&body body) &body body)
"Group some output into a logical block. STREAM-SYMBOL should be either a "Group some output into a logical block. STREAM-SYMBOL should be either a
stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
...@@ -704,63 +715,71 @@ ...@@ -704,63 +715,71 @@
((nil) *standard-output*) ((nil) *standard-output*)
((t) *terminal-io*) ((t) *terminal-io*)
(t ,stream)))))) (t ,stream))))))
(let* ((list-var (and list (gensym))) (let* ((object-var (gensym))
(block-name (gensym)) (block-name (gensym))
(count-name (gensym)) (count-name (gensym))
(pp-pop-name (gensym)) (pp-pop-name (gensym)))
(guts `(%pprint-logical-block
`(lisp::decend-into (,list-var ,stream-var) ,stream-expression ,object ,(or prefix per-line-prefix)
(with-pretty-stream (,stream-var) ,(not (null per-line-prefix)) ,suffix
(start-logical-block ,stream-var ,allow-atoms ,descend ,check-for-circularity ,initiate-pretty-printing
,(or prefix per-line-prefix) #'(lambda (,stream-var ,object-var)
,(if per-line-prefix t nil) (let ((,count-name 0))
,suffix) (declare (type index ,count-name) (ignorable ,count-name))
(let (,@(when list `((,list-var ,list-var))) (block ,block-name
(,count-name (if *print-readably* nil *print-length*))) (flet ((,pp-pop-name ()
(declare (ignorable ,count-name)) (unless (listp ,object-var)
(block ,block-name (write-string ". " ,stream-var)
(flet ((,pp-pop-name () (output-object ,object-var ,stream-var)
,@(when list-var (return-from ,block-name nil))
`((unless (listp ,list-var) (when (eql ,count-name *print-length*)
(write-string ". " ,stream-var) (write-string "..." ,stream-var)
(output-object ,list-var ,stream-var) (return-from ,block-name nil))
(return-from ,block-name nil)))) (when (and ,object-var
(when (and ,count-name (plusp ,count-name)
(minusp (decf ,count-name))) (check-for-circularity ,object-var))
(write-string "..." ,stream-var) (write-string ". " ,stream-var)
(return-from ,block-name nil)) (output-object ,object-var ,stream-var)
,@(when list-var (return-from ,block-name nil))
`((when (lisp::check-for-circularity (incf ,count-name)
,list-var) (pop ,object-var)))
(write-string ". " ,stream-var) (declare (ignorable #',pp-pop-name))
(output-object ,list-var ,stream-var) (macrolet ((pprint-pop ()
(return-from ,block-name nil)) '(,pp-pop-name))
(pop ,list-var))))) (pprint-exit-if-list-exhausted ()
;#',pp-pop-name ;; Ignorable `(when (null ,',object-var)
(macrolet (return-from ,',block-name nil))))
((pprint-pop () ,@body)))))))))
`(,',pp-pop-name))
(pprint-exit-if-list-exhausted () (defun %pprint-logical-block (stream object prefix per-line-p suffix
,(if list allow-atoms descend check-circularity
``(unless ,',list-var initiate-pretty-printing body)
(return-from ,',block-name nil)) (if (or allow-atoms (listp object))
'(error (labels ((do-body (stream)
"Cannot use PPRINT-EXIT-IF-LIST-EXHAUSTED ~ (start-logical-block stream prefix per-line-p suffix)
when NIL was supplied as the list ~@ (funcall body stream (if allow-atoms nil object))
argument to PPRINT-LOGICAL-BLOCK because ~ (end-logical-block stream))
there is no associated list.")))) (maybe-init (stream)
,@body)))) (cond ((pretty-stream-p stream)
(end-logical-block ,stream-var))))) (do-body stream))
`(progn (initiate-pretty-printing
,(if list (with-pretty-stream (stream)
`(let ((,stream-var ,stream-expression) (do-body stream)))
(,list-var ,list)) (t
(if (listp ,list-var) (write-string prefix stream)
,guts (funcall body stream (if allow-atoms nil object))
(output-object ,list-var ,stream-var))) (write-string suffix stream))))
`(let ((,stream-var ,stream-expression)) (maybe-circular ()
,guts)) (if (and object check-circularity)
nil)))) (with-circularity-detection (object stream)
(maybe-init stream))
(maybe-init stream))))
(if descend
(descend-into (nil stream)
(maybe-circular))
(maybe-circular)))
(output-object object stream))
nil)
(defmacro pprint-exit-if-list-exhausted () (defmacro pprint-exit-if-list-exhausted ()
"Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
...@@ -1097,19 +1116,17 @@ ...@@ -1097,19 +1116,17 @@
(pprint-multi-dim-array stream array)))) (pprint-multi-dim-array stream array))))
(defun pprint-vector (stream vector) (defun pprint-vector (stream vector)
(decend-into (vector stream) (pprint-logical-block (stream vector :allow-atoms t
(with-pretty-stream (stream) :prefix "#(" :suffix ")")
(start-logical-block stream "#(" nil ")") (dotimes (i (length vector))
(dotimes (i (length vector)) (pprint-pop)
(punt-if-too-long i stream) (unless (zerop i)
(unless (zerop i) (write-char #\space stream)
(write-char #\space stream) (pprint-newline :fill stream))
(pprint-newline :fill stream)) (output-object (aref vector i) stream))))
(output-object (aref vector i) stream))
(end-logical-block stream))))
(defun pprint-multi-dim-array (stream array) (defun pprint-multi-dim-array (stream array)
(decend-into (array stream) (pprint-logical-block (stream array :descend nil :allow-atoms t)
(funcall (formatter "#~DA") stream (array-rank array)) (funcall (formatter "#~DA") stream (array-rank array))
(lisp::with-array-data ((data array) (start) (end)) (lisp::with-array-data ((data array) (start) (end))
(declare (ignore end)) (declare (ignore end))
...@@ -1354,7 +1371,7 @@ ...@@ -1354,7 +1371,7 @@
(defun pprint-function-call (stream list &rest noise) (defun pprint-function-call (stream list &rest noise)
(declare (ignore noise)) (declare (ignore noise))
(funcall (formatter "~:<~^~W~^ ~@_~:I~@{~W~^ ~_~}~:>") (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
stream stream
list)) list))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment