org.armedbear.lisp.pprint.lisp Maven / Gradle / Ivy
Go to download
Show more of this group Show more artifacts with this name
Show all versions of abcl Show documentation
Show all versions of abcl Show documentation
Common Lisp implementation running on the JVM
;;; pprint.lisp
;;;
;;; Copyright (C) 2004-2005 Peter Graves
;;; $Id: pprint.lisp 13408 2011-07-16 22:49:01Z ehuelsmann $
;;;
;;; This program 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.
;;;
;;; This program 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 this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module. An independent module is a module which is not derived from
;;; or based on this library. If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
;;; Adapted from the November, 26 1991 version of Richard C. Waters' XP pretty
;;; printer.
;------------------------------------------------------------------------
;Copyright Massachusetts Institute of Technology, Cambridge, Massachusetts.
;Permission to use, copy, modify, and distribute this software and its
;documentation for any purpose and without fee is hereby granted,
;provided that this copyright and permission notice appear in all
;copies and supporting documentation, and that the name of M.I.T. not
;be used in advertising or publicity pertaining to distribution of the
;software without specific, written prior permission. M.I.T. makes no
;representations about the suitability of this software for any
;purpose. It is provided "as is" without express or implied warranty.
; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
; SOFTWARE.
;------------------------------------------------------------------------
(in-package #:xp)
;must do the following in common lisps not supporting *print-shared*
(defvar *print-shared* nil)
(export '(*print-shared*))
(defvar *default-right-margin* 70.
"controls default line length; must be a non-negative integer")
(defvar *current-level* 0
"current depth in logical blocks.")
(defvar *abbreviation-happened* nil
"t if current thing being printed has been abbreviated.")
(defvar *result* nil "used to pass back a value")
;default (bad) definitions for the non-portable functions
#-(or :symbolics :lucid :franz-inc :cmu)(eval-when (eval load compile)
(defun structure-type-p (x) (and (symbolp x) (get x 'structure-printer)))
(defun output-width (&optional (s *standard-output*)) (declare (ignore s)) nil))
(defvar *locating-circularities* nil
"Integer if making a first pass over things to identify circularities.
Integer used as counter for #n= syntax.")
; ---- XP STRUCTURES, AND THE INTERNAL ALGORITHM ----
(eval-when (eval load compile) ;not used at run time.
(defvar block-stack-entry-size 1)
(defvar prefix-stack-entry-size 5)
(defvar queue-entry-size 7)
(defvar buffer-entry-size 1)
(defvar prefix-entry-size 1)
(defvar suffix-entry-size 1))
(eval-when (eval load compile) ;used at run time
(defvar block-stack-min-size #.(* 35. block-stack-entry-size))
(defvar prefix-stack-min-size #.(* 30. prefix-stack-entry-size))
(defvar queue-min-size #.(* 75. queue-entry-size))
(defvar buffer-min-size 256.)
(defvar prefix-min-size 256.)
(defvar suffix-min-size 256.)
)
(defstruct (xp-structure (:conc-name nil) #+nil (:print-function describe-xp))
(base-stream nil) ;;The stream io eventually goes to.
line-length ;;The line length to use for formatting.
line-limit ;;If non-NIL the max number of lines to print.
line-no ;;number of next line to be printed.
depth-in-blocks
;;Number of logical blocks at QRIGHT that are started but not ended.
(block-stack (make-array #.block-stack-min-size)) block-stack-ptr
;;This stack is pushed and popped in accordance with the way blocks are
;;nested at the moment they are entered into the queue. It contains the
;;following block specific value.
;;SECTION-START total position where the section (see AIM-1102)
;;that is rightmost in the queue started.
(buffer (make-array #.buffer-min-size :element-type 'character))
charpos buffer-ptr buffer-offset
;;This is a vector of characters (eg a string) that builds up the
;;line images that will be printed out. BUFFER-PTR is the
;;buffer position where the next character should be inserted in
;;the string. CHARPOS is the output character position of the
;;first character in the buffer (non-zero only if a partial line
;;has been output). BUFFER-OFFSET is used in computing total lengths.
;;It is changed to reflect all shifting and insertion of prefixes so that
;;total length computes things as they would be if they were
;;all on one line. Positions are kept three different ways
;; Buffer position (eg BUFFER-PTR)
;; Line position (eg (+ BUFFER-PTR CHARPOS)). Indentations are stored in this form.
;; Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET))
;; Positions are stored in this form.
(queue (make-array #.queue-min-size))
qleft
qright
;;This holds a queue of action descriptors. QLEFT and QRIGHT
;;point to the next entry to dequeue and the last entry enqueued
;;respectively. The queue is empty when
;;(> QLEFT QRIGHT). The queue entries have several parts:
;;QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK
;;QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH
;; or :BLOCK/:CURRENT
;;QPOS total position corresponding to this entry
;;QDEPTH depth in blocks of this entry.
;;QEND offset to entry marking end of section this entry starts. (NIL until known.)
;; Only :start-block and non-literal :newline entries can start sections.
;;QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known).
;;QARG for :IND indentation delta
;; for :START-BLOCK suffix in the block if any.
;; or if per-line-prefix then cons of suffix and
;; per-line-prefix.
;; for :END-BLOCK suffix for the block if any.
(prefix (make-array #.buffer-min-size :element-type 'character))
;;this stores the prefix that should be used at the start of the line
(prefix-stack (make-array #.prefix-stack-min-size))
prefix-stack-ptr
;;This stack is pushed and popped in accordance with the way blocks
;;are nested at the moment things are taken off the queue and printed.
;;It contains the following block specific values.
;;PREFIX-PTR current length of PREFIX.
;;SUFFIX-PTR current length of pending suffix
;;NON-BLANK-PREFIX-PTR current length of non-blank prefix.
;;INITIAL-PREFIX-PTR prefix-ptr at the start of this block.
;;SECTION-START-LINE line-no value at last non-literal break at this level.
(suffix (make-array #.buffer-min-size :element-type 'character))
;;this stores the suffixes that have to be printed to close of the current
;;open blocks. For convenient in popping, the whole suffix
;;is stored in reverse order.
)
(defun ext:charpos (stream)
(cond ((xp-structure-p stream)
(charpos stream))
((streamp stream)
(sys::stream-charpos stream))))
(defun (setf ext:charpos) (new-value stream)
(cond ((xp-structure-p stream)
(setf (charpos stream) new-value))
((streamp stream)
(sys::stream-%set-charpos stream new-value))))
(defmacro LP<-BP (xp &optional (ptr nil))
(if (null ptr) (setq ptr `(buffer-ptr ,xp)))
`(+ ,ptr (charpos ,xp)))
(defmacro TP<-BP (xp)
`(+ (buffer-ptr ,xp) (buffer-offset ,xp)))
(defmacro BP<-LP (xp ptr)
`(- ,ptr (charpos ,xp)))
(defmacro BP<-TP (xp ptr)
`(- ,ptr (buffer-offset ,xp)))
;This does not tell you the line position you were at when the TP
;was set, unless there have been no newlines or indentation output
;between ptr and the current output point.
(defmacro LP<-TP (xp ptr)
`(LP<-BP ,xp (BP<-TP ,xp ,ptr)))
;We don't use adjustable vectors or any of that, because we seldom have
;to actually extend and non-adjustable vectors are a lot faster in
;many Common Lisps.
(defmacro check-size (xp vect ptr)
(let* ((min-size
(symbol-value
(intern (concatenate 'string (string vect) "-MIN-SIZE")
(find-package "XP"))))
(entry-size
(symbol-value
(intern (concatenate 'string (string vect) "-ENTRY-SIZE")
(find-package "XP")))))
`(when (and (> ,ptr ,(- min-size entry-size)) ;seldom happens
(> ,ptr (- (length (,vect ,xp)) ,entry-size)))
(let* ((old (,vect ,xp))
(new (make-array (+ ,ptr ,(if (= entry-size 1) 50
(* 10 entry-size)))
:element-type (array-element-type old))))
(replace new old)
(setf (,vect ,xp) new)))))
(defmacro section-start (xp) `(aref (block-stack ,xp) (block-stack-ptr ,xp)))
(defun push-block-stack (xp)
(incf (block-stack-ptr xp) #.block-stack-entry-size)
(check-size xp block-stack (block-stack-ptr xp)))
(defun pop-block-stack (xp)
(decf (block-stack-ptr xp) #.block-stack-entry-size))
(defmacro prefix-ptr (xp)
`(aref (prefix-stack ,xp) (prefix-stack-ptr ,xp)))
(defmacro suffix-ptr (xp)
`(aref (prefix-stack ,xp) (+ (prefix-stack-ptr ,xp) 1)))
(defmacro non-blank-prefix-ptr (xp)
`(aref (prefix-stack ,xp) (+ (prefix-stack-ptr ,xp) 2)))
(defmacro initial-prefix-ptr (xp)
`(aref (prefix-stack ,xp) (+ (prefix-stack-ptr ,xp) 3)))
(defmacro section-start-line (xp)
`(aref (prefix-stack ,xp) (+ (prefix-stack-ptr ,xp) 4)))
(defun push-prefix-stack (xp)
(let ((old-prefix 0)
(old-suffix 0)
(old-non-blank 0))
(when (not (minusp (prefix-stack-ptr xp)))
(setq old-prefix (prefix-ptr xp)
old-suffix (suffix-ptr xp)
old-non-blank (non-blank-prefix-ptr xp)))
(incf (prefix-stack-ptr xp) #.prefix-stack-entry-size)
(check-size xp prefix-stack (prefix-stack-ptr xp))
(setf (prefix-ptr xp) old-prefix)
(setf (suffix-ptr xp) old-suffix)
(setf (non-blank-prefix-ptr xp) old-non-blank)))
(defun pop-prefix-stack (xp)
(decf (prefix-stack-ptr xp) #.prefix-stack-entry-size))
(defmacro Qtype (xp index) `(aref (queue ,xp) ,index))
(defmacro Qkind (xp index) `(aref (queue ,xp) (1+ ,index)))
(defmacro Qpos (xp index) `(aref (queue ,xp) (+ ,index 2)))
(defmacro Qdepth (xp index) `(aref (queue ,xp) (+ ,index 3)))
(defmacro Qend (xp index) `(aref (queue ,xp) (+ ,index 4)))
(defmacro Qoffset (xp index) `(aref (queue ,xp) (+ ,index 5)))
(defmacro Qarg (xp index) `(aref (queue ,xp) (+ ,index 6)))
;we shift the queue over rather than using a circular queue because
;that works out to be a lot faster in practice. Note, short printout
;does not ever cause a shift, and even in long printout, the queue is
;shifted left for free every time it happens to empty out.
(defun enqueue (xp type kind &optional arg)
(incf (Qright xp) #.queue-entry-size)
(when (> (Qright xp) #.(- queue-min-size queue-entry-size))
(replace (queue xp) (queue xp) :start2 (Qleft xp) :end2 (Qright xp))
(setf (Qright xp) (- (Qright xp) (Qleft xp)))
(setf (Qleft xp) 0))
(check-size xp queue (Qright xp))
(setf (Qtype xp (Qright xp)) type)
(setf (Qkind xp (Qright xp)) kind)
(setf (Qpos xp (Qright xp)) (TP<-BP xp))
(setf (Qdepth xp (Qright xp)) (depth-in-blocks xp))
(setf (Qend xp (Qright xp)) nil)
(setf (Qoffset xp (Qright xp)) nil)
(setf (Qarg xp (Qright xp)) arg))
(defmacro Qnext (index) `(+ ,index #.queue-entry-size))
;This is called to initialize things when you start pretty printing.
(defun initialize-xp (xp stream)
(setf (base-stream xp) stream)
(setf (line-length xp) (max 0 (cond (*print-right-margin*)
((output-width stream))
(t *default-right-margin*))))
(setf (line-limit xp) *print-lines*)
(setf (line-no xp) 1)
(setf (depth-in-blocks xp) 0)
(setf (block-stack-ptr xp) 0)
(setf (charpos xp) (cond ((ext:charpos stream)) (t 0)))
(setf (section-start xp) 0)
(setf (buffer-ptr xp) 0)
(setf (buffer-offset xp) (charpos xp))
(setf (Qleft xp) 0)
(setf (Qright xp) #.(- queue-entry-size))
(setf (prefix-stack-ptr xp) #.(- prefix-stack-entry-size))
xp)
;This handles the basic outputting of characters. note + suffix means that
;the stream is known to be an XP stream, all inputs are mandatory, and no
;error checking has to be done. Suffix ++ additionally means that the
;output is guaranteed not to contain a newline char.
(defun write-char+ (char xp)
(if (eql char #\newline) (pprint-newline+ :unconditional xp)
(write-char++ char xp)))
(defun write-string+ (string xp start end)
(let ((sub-end nil) next-newline)
(loop (setq next-newline
(position #\newline string :test #'char= :start start :end end))
(setq sub-end (if next-newline next-newline end))
(write-string++ string xp start sub-end)
(when (null next-newline) (return nil))
(pprint-newline+ :unconditional xp)
(setq start (1+ sub-end)))))
;note this checks (> BUFFER-PTR LINE-LENGTH) instead of (> (LP<-BP) LINE-LENGTH)
;this is important so that when things are longer than a line they
;end up getting printed in chunks of size LINE-LENGTH.
(defun write-char++ (char xp)
(when (> (buffer-ptr xp) (line-length xp))
(force-some-output xp))
(let ((new-buffer-end (1+ (buffer-ptr xp))))
(check-size xp buffer new-buffer-end)
(setf (char (buffer xp) (buffer-ptr xp)) char)
(setf (buffer-ptr xp) new-buffer-end)))
(defun force-some-output (xp)
(attempt-to-output xp nil nil)
(when (> (buffer-ptr xp) (line-length xp)) ;only if printing off end of line
(attempt-to-output xp T T)))
(defun write-string++ (string xp start end)
(when (> (buffer-ptr xp) (line-length xp))
(force-some-output xp))
(write-string+++ string xp start end))
;never forces output; therefore safe to call from within output-line.
(defun write-string+++ (string xp start end)
(let ((new-buffer-end (+ (buffer-ptr xp) (- end start))))
(check-size xp buffer new-buffer-end)
(do ((buffer (buffer xp))
(i (buffer-ptr xp) (1+ i))
(j start (1+ j)))
((= j end))
(let ((char (char string j)))
(setf (char buffer i) char)))
(setf (buffer-ptr xp) new-buffer-end)))
(defun pprint-tab+ (kind colnum colinc xp)
(let ((indented? nil) (relative? nil))
(case kind
(:section (setq indented? t))
(:line-relative (setq relative? t))
(:section-relative (setq indented? t relative? t)))
(let* ((current
(if (not indented?) (LP<-BP xp)
(- (TP<-BP xp) (section-start xp))))
(new
(if (zerop colinc)
(if relative? (+ current colnum) (max colnum current))
(cond (relative?
(* colinc (floor (+ current colnum colinc -1) colinc)))
((> colnum current) colnum)
(T (+ colnum
(* colinc
(floor (+ current (- colnum) colinc) colinc)))))))
(length (- new current)))
(when (plusp length)
(let ((end (+ (buffer-ptr xp) length)))
(check-size xp buffer end)
(fill (buffer xp) #\space :start (buffer-ptr xp) :end end)
(setf (buffer-ptr xp) end))))))
;note following is smallest number >= x that is a multiple of colinc
; (* colinc (floor (+ x (1- colinc)) colinc))
(defun pprint-newline+ (kind xp)
(enqueue xp :newline kind)
(do ((ptr (Qleft xp) (Qnext ptr))) ;find sections we are ending
((not (< ptr (Qright xp)))) ;all but last
(when (and (null (Qend xp ptr))
(not (> (depth-in-blocks xp) (Qdepth xp ptr)))
(member (Qtype xp ptr) '(:newline :start-block)))
(setf (Qend xp ptr) (- (Qright xp) ptr))))
(setf (section-start xp) (TP<-BP xp))
(when (member kind '(:fresh :unconditional :mandatory))
(attempt-to-output xp T nil)))
(defun start-block (xp prefix on-each-line? suffix)
(unless (stringp prefix)
(error 'type-error
:datum prefix
:expected-type 'string))
(unless (stringp suffix)
(error 'type-error
:datum suffix
:expected-type 'string))
(when prefix
(write-string++ prefix xp 0 (length prefix)))
(push-block-stack xp)
(enqueue xp :start-block nil
(if on-each-line? (cons suffix prefix) suffix))
(incf (depth-in-blocks xp)) ;must be after enqueue
(setf (section-start xp) (TP<-BP xp)))
(defun end-block (xp suffix)
(unless (eq *abbreviation-happened* '*print-lines*)
(when suffix
(write-string+ suffix xp 0 (length suffix)))
(decf (depth-in-blocks xp))
(enqueue xp :end-block nil suffix)
(do ((ptr (Qleft xp) (Qnext ptr))) ;looking for start of block we are ending
((not (< ptr (Qright xp)))) ;all but last
(when (and (= (depth-in-blocks xp) (Qdepth xp ptr))
(eq (Qtype xp ptr) :start-block)
(null (Qoffset xp ptr)))
(setf (Qoffset xp ptr) (- (Qright xp) ptr))
(return nil))) ;can only be 1
(pop-block-stack xp)))
(defun pprint-indent+ (kind n xp)
(enqueue xp :ind kind n))
; The next function scans the queue looking for things it can do.
;it keeps outputting things until the queue is empty, or it finds
;a place where it cannot make a decision yet.
(defmacro maybe-too-large (xp Qentry)
`(let ((limit (line-length ,xp)))
(when (eql (line-limit ,xp) (line-no ,xp)) ;prevents suffix overflow
(decf limit 2) ;3 for " .." minus 1 for space (heuristic)
(when (not (minusp (prefix-stack-ptr ,xp)))
(decf limit (suffix-ptr ,xp))))
(cond ((Qend ,xp ,Qentry)
(> (LP<-TP ,xp (Qpos ,xp (+ ,Qentry (Qend ,xp ,Qentry)))) limit))
((or force-newlines? (> (LP<-BP ,xp) limit)) T)
(T (return nil))))) ;wait until later to decide.
(defmacro misering? (xp)
`(and *print-miser-width*
(<= (- (line-length ,xp) (initial-prefix-ptr ,xp)) *print-miser-width*)))
;If flush-out? is T and force-newlines? is NIL then the buffer,
;prefix-stack, and queue will be in an inconsistent state after the call.
;You better not call it this way except as the last act of outputting.
(defun attempt-to-output (xp force-newlines? flush-out?)
(do () ((> (Qleft xp) (Qright xp))
(setf (Qleft xp) 0)
(setf (Qright xp) #.(- queue-entry-size))) ;saves shifting
(case (Qtype xp (Qleft xp))
(:ind
(unless (misering? xp)
(set-indentation-prefix xp
(case (Qkind xp (Qleft xp))
(:block (+ (initial-prefix-ptr xp) (Qarg xp (Qleft xp))))
(T ; :current
(+ (LP<-TP xp (Qpos xp (Qleft xp)))
(Qarg xp (Qleft xp)))))))
(setf (Qleft xp) (Qnext (Qleft xp))))
(:start-block
(cond ((maybe-too-large xp (Qleft xp))
(push-prefix-stack xp)
(setf (initial-prefix-ptr xp) (prefix-ptr xp))
(set-indentation-prefix xp (LP<-TP xp (Qpos xp (Qleft xp))))
(let ((arg (Qarg xp (Qleft xp))))
(when (consp arg) (set-prefix xp (cdr arg)))
(setf (initial-prefix-ptr xp) (prefix-ptr xp))
(cond ((not (listp arg)) (set-suffix xp arg))
((car arg) (set-suffix xp (car arg)))))
(setf (section-start-line xp) (line-no xp)))
(T (incf (Qleft xp) (Qoffset xp (Qleft xp)))))
(setf (Qleft xp) (Qnext (Qleft xp))))
(:end-block (pop-prefix-stack xp) (setf (Qleft xp) (Qnext (Qleft xp))))
(T ; :newline
(when (case (Qkind xp (Qleft xp))
(:fresh (not (zerop (LP<-BP xp))))
(:miser (misering? xp))
(:fill (or (misering? xp)
(> (line-no xp) (section-start-line xp))
(maybe-too-large xp (Qleft xp))))
(T T)) ;(:linear :unconditional :mandatory)
(output-line xp (Qleft xp))
(setup-for-next-line xp (Qleft xp)))
(setf (Qleft xp) (Qnext (Qleft xp))))))
(when flush-out? (flush xp)))
;this can only be called last!
(defun flush (xp)
(unless *locating-circularities*
(write-string (buffer xp) (base-stream xp) :end (buffer-ptr xp)))
(incf (buffer-offset xp) (buffer-ptr xp))
(incf (charpos xp) (buffer-ptr xp))
(setf (buffer-ptr xp) 0))
;This prints out a line of stuff.
(defun output-line (xp Qentry)
(let* ((out-point (BP<-TP xp (Qpos xp Qentry)))
(last-non-blank (position #\space (buffer xp) :test-not #'char=
:from-end T :end out-point))
(end (cond ((member (Qkind xp Qentry) '(:fresh :unconditional)) out-point)
(last-non-blank (1+ last-non-blank))
(T 0)))
(line-limit-exit (and (line-limit xp)
(not *print-readably*)
(not (> (line-limit xp) (line-no xp))))))
(when line-limit-exit
(setf (buffer-ptr xp) end) ;truncate pending output.
(write-string+++ " .." xp 0 3)
(reverse-string-in-place (suffix xp) 0 (suffix-ptr xp))
(write-string+++ (suffix xp) xp 0 (suffix-ptr xp))
(setf (Qleft xp) (Qnext (Qright xp)))
(setf *abbreviation-happened* '*print-lines*)
(throw 'line-limit-abbreviation-exit T))
(incf (line-no xp))
(unless *locating-circularities*
(let ((stream (base-stream xp)))
(sys::%write-string (buffer xp) stream 0 end)
(sys::%terpri stream)))))
(defun setup-for-next-line (xp Qentry)
(let* ((out-point (BP<-TP xp (Qpos xp Qentry)))
(prefix-end
(cond ((member (Qkind xp Qentry) '(:unconditional :fresh))
(non-blank-prefix-ptr xp))
(T (prefix-ptr xp))))
(change (- prefix-end out-point)))
(setf (charpos xp) 0)
(when (plusp change) ;almost never happens
(check-size xp buffer (+ (buffer-ptr xp) change)))
(replace (buffer xp) (buffer xp) :start1 prefix-end
:start2 out-point :end2 (buffer-ptr xp))
(replace (buffer xp) (prefix xp) :end2 prefix-end)
(incf (buffer-ptr xp) change)
(decf (buffer-offset xp) change)
(when (not (member (Qkind xp Qentry) '(:unconditional :fresh)))
(setf (section-start-line xp) (line-no xp)))))
(defun set-indentation-prefix (xp new-position)
(let ((new-ind (max (non-blank-prefix-ptr xp) new-position)))
(setf (prefix-ptr xp) (initial-prefix-ptr xp))
(check-size xp prefix new-ind)
(when (> new-ind (prefix-ptr xp))
(fill (prefix xp) #\space :start (prefix-ptr xp) :end new-ind))
(setf (prefix-ptr xp) new-ind)))
(defun set-prefix (xp prefix-string)
(replace (prefix xp) prefix-string
:start1 (- (prefix-ptr xp) (length prefix-string)))
(setf (non-blank-prefix-ptr xp) (prefix-ptr xp)))
(defun set-suffix (xp suffix-string)
(let* ((end (length suffix-string))
(new-end (+ (suffix-ptr xp) end)))
(check-size xp suffix new-end)
(do ((i (1- new-end) (1- i)) (j 0 (1+ j))) ((= j end))
(setf (char (suffix xp) i) (char suffix-string j)))
(setf (suffix-ptr xp) new-end)))
(defun reverse-string-in-place (string start end)
(do ((i start (1+ i)) (j (1- end) (1- j))) ((not (< i j)) string)
(let ((c (char string i)))
(setf (char string i) (char string j))
(setf (char string j) c))))
; ---- BASIC INTERFACE FUNCTIONS ----
;The internal functions in this file, and the (formatter "...") expansions
;use the '+' forms of these functions directly (which is faster) because,
;they do not need error checking of fancy stream coercion. The '++' forms
;additionally assume the thing being output does not contain a newline.
(defun write (object &key
((:stream stream) *standard-output*)
((:escape *print-escape*) *print-escape*)
((:radix *print-radix*) *print-radix*)
((:base *print-base*) *print-base*)
((:circle *print-circle*) *print-circle*)
((:pretty *print-pretty*) *print-pretty*)
((:level *print-level*) *print-level*)
((:length *print-length*) *print-length*)
((:case *print-case*) *print-case*)
((:array *print-array*) *print-array*)
((:gensym *print-gensym*) *print-gensym*)
((:readably *print-readably*) *print-readably*)
((:right-margin *print-right-margin*)
*print-right-margin*)
((:miser-width *print-miser-width*)
*print-miser-width*)
((:lines *print-lines*) *print-lines*)
((:pprint-dispatch *print-pprint-dispatch*)
*print-pprint-dispatch*))
(sys:output-object object (sys:out-synonym-of stream))
object)
(defun maybe-initiate-xp-printing (object fn stream &rest args)
(if (xp-structure-p stream)
(apply fn stream args)
(let ((*abbreviation-happened* nil)
(*result* nil))
(if (and *print-circle* (null sys::*circularity-hash-table*))
(let ((sys::*circularity-hash-table* (make-hash-table :test 'eq)))
(setf (gethash object sys::*circularity-hash-table*) t)
(xp-print fn (make-broadcast-stream) args)
(let ((sys::*circularity-counter* 0))
(when (eql 0 (gethash object sys::*circularity-hash-table*))
(setf (gethash object sys::*circularity-hash-table*)
(incf sys::*circularity-counter*))
(sys::print-label (gethash object sys::*circularity-hash-table*)
(sys:out-synonym-of stream)))
(xp-print fn (sys:out-synonym-of stream) args)))
(xp-print fn (sys:out-synonym-of stream) args))
*result*)))
(defun xp-print (fn stream args)
(setq *result* (do-xp-printing fn stream args))
(when *locating-circularities*
(setq *locating-circularities* nil)
(setq *abbreviation-happened* nil)
;; (setq *parents* nil)
(setq *result* (do-xp-printing fn stream args))))
(defun do-xp-printing (fn stream args)
(let ((xp (initialize-xp (make-xp-structure) stream))
(*current-level* 0)
(result nil))
(catch 'line-limit-abbreviation-exit
(start-block xp "" nil "")
(setq result (apply fn xp args))
(end-block xp nil))
(when (and *locating-circularities*
(zerop *locating-circularities*) ;No circularities.
(= (line-no xp) 1) ;Didn't suppress line.
(zerop (buffer-offset xp))) ;Didn't suppress partial line.
(setq *locating-circularities* nil)) ;print what you have got.
(when (catch 'line-limit-abbreviation-exit
(attempt-to-output xp nil t) nil)
(attempt-to-output xp t t))
result))
(defun write+ (object xp)
;; (let ((*parents* *parents*))
;; (unless (and *circularity-hash-table*
;; (eq (circularity-process xp object nil) :subsequent))
;; (when (and *circularity-hash-table* (consp object))
;; ;;avoid possible double check in handle-logical-block.
;; (setq object (cons (car object) (cdr object))))
(let ((printer (if *print-pretty* (get-printer object *print-pprint-dispatch*) nil))
type)
(cond (printer (funcall printer xp object))
((maybe-print-fast object xp))
((and *print-pretty*
(symbolp (setq type (type-of object)))
(setq printer (get type 'structure-printer))
(not (eq printer :none)))
(funcall printer xp object))
((and *print-pretty* *print-array* (arrayp object)
(not (stringp object)) (not (bit-vector-p object))
(not (structure-type-p (type-of object))))
(pretty-array xp object))
(t
(let ((stuff (with-output-to-string (s) (non-pretty-print object s))))
(write-string+ stuff xp 0 (length stuff)))))))
(defun non-pretty-print (object s)
;; (write object
;; :level (if *print-level*
;; (- *print-level* *current-level*))
;; :pretty nil
;; :stream s))
(sys::output-ugly-object object s))
;This prints a few very common, simple atoms very fast.
;Pragmatically, this turns out to be an enormous savings over going to the
;standard printer all the time. There would be diminishing returns from making
;this work with more things, but might be worth it.
(defun maybe-print-fast (object xp)
(cond ((stringp object)
(let ((s (sys::%write-to-string object)))
(write-string++ s xp 0 (length s))
t))
((ext:fixnump object)
(print-fixnum xp object)
t)
((and (symbolp object)
(or (symbol-package object)
(null *print-circle*)))
(let ((s (sys::%write-to-string object)))
(write-string++ s xp 0 (length s))
t)
)))
(defun print-fixnum (xp fixnum)
(let ((s (sys::%write-to-string fixnum)))
(write-string++ s xp 0 (length s))))
(defun print (object &optional (stream *standard-output*))
(setf stream (sys:out-synonym-of stream))
(terpri stream)
(let ((*print-escape* t))
(sys:output-object object stream))
(write-char #\space stream)
object)
(defun prin1 (object &optional (stream *standard-output*))
(let ((*print-escape* t))
(sys:output-object object (sys:out-synonym-of stream)))
object)
(defun princ (object &optional (stream *standard-output*))
(let ((*print-escape* nil)
(*print-readably* nil))
(sys:output-object object (sys:out-synonym-of stream)))
object)
(defun pprint (object &optional (stream *standard-output*))
(setq stream (sys:out-synonym-of stream))
(terpri stream)
(let ((*print-escape* T) (*print-pretty* T))
(sys:output-object object stream))
(values))
(defun write-to-string (object &key
((:escape *print-escape*) *print-escape*)
((:radix *print-radix*) *print-radix*)
((:base *print-base*) *print-base*)
((:circle *print-circle*) *print-circle*)
((:pretty *print-pretty*) *print-pretty*)
((:level *print-level*) *print-level*)
((:length *print-length*) *print-length*)
((:case *print-case*) *print-case*)
((:array *print-array*) *print-array*)
((:gensym *print-gensym*) *print-gensym*)
((:readably *print-readably*) *print-readably*)
((:right-margin *print-right-margin*) *print-right-margin*)
((:miser-width *print-miser-width*) *print-miser-width*)
((:lines *print-lines*) *print-lines*)
((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*))
(let ((stream (make-string-output-stream)))
(sys:output-object object stream)
(get-output-stream-string stream)))
(defun prin1-to-string (object)
(with-output-to-string (stream)
(let ((*print-escape* t))
(sys:output-object object stream))))
(defun princ-to-string (object)
(with-output-to-string (stream)
(let ((*print-escape* nil)
(*print-readably* nil))
(sys:output-object object stream))))
(defun write-char (char &optional (stream *standard-output*))
(setf stream (sys:out-synonym-of stream))
(if (xp-structure-p stream)
(write-char+ char stream)
(sys:%stream-write-char char stream))
char)
(defun write-string (string &optional (stream *standard-output*)
&key (start 0) end)
(setf stream (sys:out-synonym-of stream))
(setf end (or end (length string))) ;; default value for end is NIL
(if (xp-structure-p stream)
(write-string+ string stream start end)
(progn
(unless start
(setf start 0))
(if end
(setf end (min end (length string)))
(setf end (length string)))
(sys::%write-string string stream start end)))
string)
(defun write-line (string &optional (stream *standard-output*)
&key (start 0) end)
(setf stream (sys:out-synonym-of stream))
(setf end (or end (length string)))
(cond ((xp-structure-p stream)
(write-string+ string stream start end)
(pprint-newline+ :unconditional stream))
(t (sys::%write-string string stream start end)
(sys::%terpri stream)))
string)
(defun terpri (&optional (stream *standard-output*))
(setf stream (sys:out-synonym-of stream))
(if (xp-structure-p stream)
(pprint-newline+ :unconditional stream)
(sys:%stream-terpri stream))
nil)
;This has to violate the XP data abstraction and fool with internal
;stuff, in order to find out the right info to return as the result.
(defun fresh-line (&optional (stream *standard-output*))
(setf stream (sys:out-synonym-of stream))
(cond ((xp-structure-p stream)
(attempt-to-output stream t t) ;ok because we want newline
(when (not (zerop (LP<-BP stream)))
(pprint-newline+ :fresh stream)
t))
(t
(sys::%fresh-line stream))))
;Each of these causes the stream to be pessimistic and insert
;newlines wherever it might have to, when forcing the partial output
;out. This is so that things will be in a consistent state if
;output continues to the stream later.
(defun finish-output (&optional (stream *standard-output*))
(setf stream (sys:out-synonym-of stream))
(when (xp-structure-p stream)
(attempt-to-output stream T T)
(setf stream (base-stream stream)))
(sys::%finish-output stream)
nil)
(defun force-output (&optional (stream *standard-output*))
(setf stream (sys:out-synonym-of stream))
(when (xp-structure-p stream)
(attempt-to-output stream T T)
(setf stream (base-stream stream)))
(sys::%force-output stream)
nil)
(defun clear-output (&optional (stream *standard-output*))
(setf stream (sys:out-synonym-of stream))
(when (xp-structure-p stream)
(let ((*locating-circularities* 0)) ;hack to prevent visible output
(attempt-to-output stream T T)
(setf stream (base-stream stream))))
(sys::%clear-output stream)
nil)
;The internal functions in this file, and the (formatter "...") expansions
;use the '+' forms of these functions directly (which is faster) because,
;they do not need error checking or fancy stream coercion. The '++' forms
;additionally assume the thing being output does not contain a newline.
(defmacro pprint-logical-block ((stream-symbol object
&key
(prefix "" prefix-p)
(per-line-prefix "" per-line-prefix-p)
(suffix ""))
&body body)
(cond ((eq stream-symbol nil)
(setf stream-symbol '*standard-output*))
((eq stream-symbol t)
(setf stream-symbol '*terminal-io*)))
(unless (symbolp stream-symbol)
(warn "STREAM-SYMBOL arg ~S to PPRINT-LOGICAL-BLOCK is not a bindable symbol."
stream-symbol)
(setf stream-symbol '*standard-output*))
(when (and prefix-p per-line-prefix-p)
(error "Cannot specify values for both PREFIX and PER-LINE-PREFIX."))
`(let ((+l ,object))
(maybe-initiate-xp-printing
+l
#'(lambda (,stream-symbol)
(let ((+l +l)
(+p ,(cond (prefix-p prefix)
(per-line-prefix-p per-line-prefix)
(t "")))
(+s ,suffix))
(pprint-logical-block+
(,stream-symbol +l +p +s ,per-line-prefix-p t nil)
,@ body nil)))
(sys:out-synonym-of ,stream-symbol))))
;Assumes var and args must be variables. Other arguments must be literals or variables.
(defmacro pprint-logical-block+ ((var args prefix suffix per-line? circle-check? atsign?)
&body body)
;; (when (and circle-check? atsign?)
;; (setf circle-check? 'not-first-p))
(declare (ignore atsign?))
`(let ((*current-level* (1+ *current-level*))
(sys:*current-print-length* -1)
;; ,@(if (and circle-check? atsign?)
;; `((not-first-p (plusp sys:*current-print-length*))))
)
(unless (check-block-abbreviation ,var ,args ,circle-check?)
(block logical-block
(start-block ,var ,prefix ,per-line? ,suffix)
(unwind-protect
(macrolet ((pprint-pop () `(pprint-pop+ ,',args ,',var))
(pprint-exit-if-list-exhausted ()
`(if (null ,',args) (return-from logical-block nil))))
,@ body)
(end-block ,var ,suffix))))))
;; "If stream is a pretty printing stream and the value of *PRINT-PRETTY* is
;; true, a line break is inserted in the output when the appropriate condition
;; below is satisfied; otherwise, PPRINT-NEWLINE has no effect."
(defun pprint-newline (kind &optional (stream *standard-output*))
(sys:require-type kind '(MEMBER :LINEAR :MISER :FILL :MANDATORY))
(setq stream (sys:out-synonym-of stream))
(when (not (member kind '(:linear :miser :fill :mandatory)))
(error 'simple-type-error
:format-control "Invalid KIND argument ~A to PPRINT-NEWLINE."
:format-arguments (list kind)))
(when (and (xp-structure-p stream) *print-pretty*)
(pprint-newline+ kind stream))
nil)
;; "If stream is a pretty printing stream and the value of *PRINT-PRETTY* is
;; true, PPRINT-INDENT sets the indentation in the innermost dynamically
;; enclosing logical block; otherwise, PPRINT-INDENT has no effect."
(defun pprint-indent (relative-to n &optional (stream *standard-output*))
(setq stream (sys:out-synonym-of stream))
(when (not (member relative-to '(:block :current)))
(error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to))
(when (and (xp-structure-p stream) *print-pretty*)
(pprint-indent+ relative-to (truncate n) stream))
nil)
(defun pprint-tab (kind colnum colinc &optional (stream *standard-output*))
(setq stream (sys:out-synonym-of stream))
(when (not (member kind '(:line :section :line-relative :section-relative)))
(error "Invalid KIND argument ~A to PPRINT-TAB" kind))
(when (and (xp-structure-p stream) *print-pretty*)
(pprint-tab+ kind colnum colinc stream))
nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro pprint-pop+ (args xp)
`(if (pprint-pop-check+ ,args ,xp)
(return-from logical-block nil)
(pop ,args)))
(defun pprint-pop-check+ (args xp)
(incf sys:*current-print-length*)
(cond ((not (listp args)) ;must be first so supersedes length abbrev
(write-string++ ". " xp 0 2)
(sys:output-object args xp)
t)
((and *print-length* ;must supersede circle check
(not *print-readably*)
(not (< sys:*current-print-length* *print-length*)))
(write-string++ "..." xp 0 3)
;; (setq *abbreviation-happened* T)
t)
;; ((and *circularity-hash-table* (not (zerop sys:*current-print-length*)))
;; (case (circularity-process xp args T)
;; (:first ;; note must inhibit rechecking of circularity for args.
;; (write+ (cons (car args) (cdr args)) xp) T)
;; (:subsequent t)
;; (t nil)))
((or (not *print-circle*)
(sys::uniquely-identified-by-print-p args))
nil)
((and (plusp sys:*current-print-length*)
(sys::check-for-circularity args))
(write-string++ ". " xp 0 2)
(sys:output-object args xp)
t)
))
(defun check-block-abbreviation (xp args circle-check?)
(declare (ignore circle-check?))
(cond ((not (listp args))
(sys:output-object args xp) T)
((and *print-level*
(not *print-readably*)
(> *current-level* *print-level*))
(write-char++ #\# xp)
(setf *abbreviation-happened* t)
t)
;; ((and *circularity-hash-table*
;; circle-check?
;; (eq (circularity-process xp args nil) :subsequent)) T)
(t
nil)))
) ;; EVAL-WHEN
; ---- PRETTY PRINTING FORMATS ----
(defun pretty-array (xp array)
(cond ((vectorp array)
(pretty-vector xp array))
((zerop (array-rank array))
(when *print-readably*
(unless (eq (array-element-type array) t)
(error 'print-not-readable :object array)))
(write-string++ "#0A" xp 0 3)
(sys:output-object (aref array) xp))
(t
(pretty-non-vector xp array))))
(defun pretty-vector (xp v)
(pprint-logical-block (xp nil :prefix "#(" :suffix ")")
(let ((end (length v))
(i 0))
(when (plusp end)
(loop
(pprint-pop)
(sys:output-object (aref v i) xp)
(when (= (incf i) end)
(return nil))
(write-char++ #\space xp)
(pprint-newline+ :fill xp))))))
(declaim (special *prefix*))
(defun pretty-non-vector (xp array)
(when (and *print-readably*
(not (array-readably-printable-p array)))
(error 'print-not-readable :object array))
(let* ((bottom (1- (array-rank array)))
(indices (make-list (1+ bottom) :initial-element 0))
(dims (array-dimensions array))
(*prefix* (cl:format nil "#~DA(" (1+ bottom))))
(labels ((pretty-slice (slice)
(pprint-logical-block (xp nil :prefix *prefix* :suffix ")")
(let ((end (nth slice dims))
(spot (nthcdr slice indices))
(i 0)
(*prefix* "("))
(when (plusp end)
(loop (pprint-pop)
(setf (car spot) i)
(if (= slice bottom)
(sys:output-object (apply #'aref array indices) xp)
(pretty-slice (1+ slice)))
(if (= (incf i) end) (return nil))
(write-char++ #\space xp)
(pprint-newline+ (if (= slice bottom) :fill :linear) xp)))))))
(pretty-slice 0))))
(defun array-readably-printable-p (array)
(and (eq (array-element-type array) t)
(let ((zero (position 0 (array-dimensions array)))
(number (position 0 (array-dimensions array)
:test (complement #'eql)
:from-end t)))
(or (null zero) (null number) (> zero number)))))
;Must use pprint-logical-block (no +) in the following three, because they are
;exported functions.
(defun pprint-linear (s list &optional (colon? T) atsign?)
(declare (ignore atsign?))
(pprint-logical-block (s list :prefix (if colon? "(" "")
:suffix (if colon? ")" ""))
(pprint-exit-if-list-exhausted)
(loop
(sys:output-object (pprint-pop) s)
(pprint-exit-if-list-exhausted)
(write-char++ #\space s)
(pprint-newline+ :linear s))))
(defun pprint-fill (stream object &optional (colon-p t) at-sign-p)
(declare (ignore at-sign-p))
(pprint-logical-block (stream object :prefix (if colon-p "(" "")
:suffix (if colon-p ")" ""))
(pprint-exit-if-list-exhausted)
(loop
(sys:output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(write-char++ #\space stream)
(pprint-newline+ :fill stream))))
(defun pprint-tabular (stream list &optional (colon-p T) at-sign-p (tabsize nil))
(declare (ignore at-sign-p))
(when (null tabsize) (setq tabsize 16))
(pprint-logical-block (stream list :prefix (if colon-p "(" "")
:suffix (if colon-p ")" ""))
(pprint-exit-if-list-exhausted)
(loop
(sys:output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(write-char++ #\space stream)
(pprint-tab+ :section-relative 0 tabsize stream)
(pprint-newline+ :fill stream))))
(defun fn-call (xp list)
(funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list))
;Although idiosyncratic, I have found this very useful to avoid large
;indentations when printing out code.
(defun alternative-fn-call (xp list)
(if (> (length (symbol-name (car list))) 12)
(funcall (formatter "~:<~1I~@{~W~^ ~_~}~:>") xp list)
(funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list)))
(defun bind-list (xp list &rest args)
(declare (ignore args))
(if (do ((i 50 (1- i))
(ls list (cdr ls))) ((null ls) t)
(when (or (not (consp ls)) (not (symbolp (car ls))) (minusp i))
(return nil)))
(pprint-fill xp list)
(funcall (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>") xp list)))
(defun block-like (xp list &rest args)
(declare (ignore args))
(funcall (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>") xp list))
(defun defun-like (xp list &rest args)
(declare (ignore args))
(funcall (formatter "~:<~1I~W~^ ~@_~W~^ ~@_~:/xp:pprint-fill/~^~@{ ~_~W~^~}~:>")
xp list))
(defun print-fancy-fn-call (xp list template)
(let ((i 0) (in-first-section t))
(pprint-logical-block+ (xp list "(" ")" nil t nil)
(sys:output-object (pprint-pop) xp)
(pprint-indent+ :current 1 xp)
(loop
(pprint-exit-if-list-exhausted)
(write-char++ #\space xp)
(when (eq i (car template))
(pprint-indent+ :block (cadr template) xp)
(setq template (cddr template))
(setq in-first-section nil))
(pprint-newline (cond ((and (zerop i) in-first-section) :miser)
(in-first-section :fill)
(T :linear))
xp)
(sys:output-object (pprint-pop) xp)
(incf i)))))
;This is an attempt to specify a correct format for every form in the CL book
;that does not just get printed out like an ordinary function call
;(i.e., most special forms and many macros). This of course does not
;cover anything new you define.
(defun let-print (xp obj)
(funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
xp obj))
(defun cond-print (xp obj)
(funcall (formatter "~:<~W~^ ~:I~@_~@{~:/xp:pprint-linear/~^ ~_~}~:>") xp obj))
(defun dmm-print (xp list)
(print-fancy-fn-call xp list '(3 1)))
(defun defsetf-print (xp list)
(print-fancy-fn-call xp list '(3 1)))
(defun do-print (xp obj)
(funcall
(formatter "~:<~W~^ ~:I~@_~/xp:bind-list/~^ ~_~:/xp:pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>")
xp obj))
(defun flet-print (xp obj)
(funcall (formatter "~:<~1I~W~^ ~@_~:<~@{~/xp:block-like/~^ ~_~}~:>~^~@{ ~_~W~^~}~:>")
xp obj))
(defun function-print (xp list)
(if (and (consp (cdr list)) (null (cddr list)))
(funcall (formatter "#'~W") xp (cadr list))
(fn-call xp list)))
(defun mvb-print (xp list)
(print-fancy-fn-call xp list '(1 3 2 1)))
;; Used by PROG-PRINT and TAGBODY-PRINT.
(defun maybelab (xp item &rest args)
(declare (ignore args) (special need-newline indentation))
(when need-newline (pprint-newline+ :mandatory xp))
(cond ((and item (symbolp item))
(write+ item xp)
(setq need-newline nil))
(t (pprint-tab+ :section indentation 0 xp)
(write+ item xp)
(setq need-newline T))))
(defun prog-print (xp list)
(let ((need-newline T) (indentation (1+ (length (symbol-name (car list))))))
(declare (special need-newline indentation))
(funcall (formatter "~:<~W~^ ~:/xp:pprint-fill/~^ ~@{~/xp:maybelab/~^ ~}~:>")
xp list)))
(defun tagbody-print (xp list)
(let ((need-newline (and (consp (cdr list))
(symbolp (cadr list)) (cadr list)))
(indentation (1+ (length (symbol-name (car list))))))
(declare (special need-newline indentation))
(funcall (formatter "~:<~W~^ ~@{~/xp:maybelab/~^ ~}~:>") xp list)))
(defun setq-print (xp obj)
(funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>") xp obj))
(defun quote-print (xp list)
(if (and (consp (cdr list)) (null (cddr list)))
(funcall (formatter "'~W") xp (cadr list))
(pprint-fill xp list)))
(defun up-print (xp list)
(print-fancy-fn-call xp list '(0 3 1 1)))
;here is some simple stuff for printing LOOP
;The challange here is that we have to effectively parse the clauses of the
;loop in order to know how to print things. Also you want to do this in a
;purely incremental way so that all of the abbreviation things work, and
;you wont blow up on circular lists or the like. (More aesthic output could
;be produced by really parsing the clauses into nested lists before printing them.)
;The following program assumes the following simplified grammar of the loop
;clauses that explains how to print them. Note that it does not bare much
;resemblence to the right parsing grammar, however, it produces half decent
;output. The way to make the output better is to make the grammar more
;detailed.
;
;loop == (LOOP {clause}*) ;one clause on each line.
;clause == block | linear | cond | finally
;block == block-head {expr}* ;as many exprs as possible on each line.
;linear == linear-head {expr}* ;one expr on each line.
;finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line.
;cond == cond-head [expr]
; clause
; {AND clause}* ;one AND on each line.
; [ELSE
; clause
; {AND clause}*] ;one AND on each line.
; [END]
;block-head == FOR | AS | WITH | AND
; | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN
; | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT
; | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING
;linear-head == DO | DOING | INITIALLY
;var-head == FOR | AS | WITH
;cond-head == IF | WHEN | UNLESS
;expr ==
;Note all the string comparisons below are required to support some
;existing implementations of LOOP.
(defun token-type (token &aux string)
(cond ((not (symbolp token)) :expr)
((string= (setq string (string token)) "FINALLY") :finally)
((member string '("IF" "WHEN" "UNLESS") :test #'string=) :cond-head)
((member string '("DO" "DOING" "INITIALLY") :test #'string=) :linear-head)
((member string '("FOR" "AS" "WITH" "AND" "END" "ELSE"
"REPEAT" "NAMED" "WHILE" "UNTIL" "ALWAYS" "NEVER"
"THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND"
"APPENDING" "NCONC" "NCONCING" "COUNT" "COUNTING"
"SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING"
"MINIMIZE" "MINIMIZING")
:test #'string=)
:block-head)
(T :expr)))
(defun pretty-loop (xp loop)
(if (not (and (consp (cdr loop)) (symbolp (cadr loop)))) ; old-style loop
(fn-call xp loop)
(pprint-logical-block (xp loop :prefix "(" :suffix ")")
(let (token type)
(labels ((next-token ()
(pprint-exit-if-list-exhausted)
(setq token (pprint-pop))
(setq type (token-type token)))
(print-clause (xp)
(case type
(:linear-head (print-exprs xp nil :mandatory))
(:cond-head (print-cond xp))
(:finally (print-exprs xp T :mandatory))
(otherwise (print-exprs xp nil :fill))))
(print-exprs (xp skip-first-non-expr newline-type)
(let ((first token))
(next-token) ;so always happens no matter what
(pprint-logical-block (xp nil)
(write first :stream xp)
(when (and skip-first-non-expr (not (eq type :expr)))
(write-char #\space xp)
(write token :stream xp)
(next-token))
(when (eq type :expr)
(write-char #\space xp)
(pprint-indent :current 0 xp)
(loop (write token :stream xp)
(next-token)
(when (not (eq type :expr)) (return nil))
(write-char #\space xp)
(pprint-newline newline-type xp))))))
(print-cond (xp)
(let ((first token))
(next-token) ;so always happens no matter what
(pprint-logical-block (xp nil)
(write first :stream xp)
(when (eq type :expr)
(write-char #\space xp)
(write token :stream xp)
(next-token))
(write-char #\space xp)
(pprint-indent :block 2 xp)
(pprint-newline :linear xp)
(print-clause xp)
(print-and-list xp)
(when (and (symbolp token)
(string= (string token) "ELSE"))
(print-else-or-end xp)
(write-char #\space xp)
(pprint-newline :linear xp)
(print-clause xp)
(print-and-list xp))
(when (and (symbolp token)
(string= (string token) "END"))
(print-else-or-end xp)))))
(print-and-list (xp)
(loop (when (not (and (symbolp token)
(string= (string token) "AND")))
(return nil))
(write-char #\space xp)
(pprint-newline :mandatory xp)
(write token :stream xp)
(next-token)
(write-char #\space xp)
(print-clause xp)))
(print-else-or-end (xp)
(write-char #\space xp)
(pprint-indent :block 0 xp)
(pprint-newline :linear xp)
(write token :stream xp)
(next-token)
(pprint-indent :block 2 xp)))
(pprint-exit-if-list-exhausted)
(write (pprint-pop) :stream xp)
(next-token)
(write-char #\space xp)
(pprint-indent :current 0 xp)
(loop (print-clause xp)
(write-char #\space xp)
(pprint-newline :linear xp)))))))
;; (defun basic-write (object stream)
;; (cond ((xp-structure-p stream)
;; (write+ object stream))
;; (*print-pretty*
;; (maybe-initiate-xp-printing #'(lambda (s o) (write+ o s))
;; stream object))
;; (t
;; (assert nil)
;; (syss:output-object object stream))))
(defun output-pretty-object (object stream)
;; (basic-write object stream))
(cond ((xp-structure-p stream)
(write+ object stream))
(*print-pretty*
(maybe-initiate-xp-printing object #'(lambda (s o) (write+ o s))
stream object))
(t
(assert nil)
(sys:output-object object stream))))
(provide "PPRINT")
;------------------------------------------------------------------------
;Copyright Massachusetts Institute of Technology, Cambridge, Massachusetts.
;Permission to use, copy, modify, and distribute this software and its
;documentation for any purpose and without fee is hereby granted,
;provided that this copyright and permission notice appear in all
;copies and supporting documentation, and that the name of M.I.T. not
;be used in advertising or publicity pertaining to distribution of the
;software without specific, written prior permission. M.I.T. makes no
;representations about the suitability of this software for any
;purpose. It is provided "as is" without express or implied warranty.
; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
; SOFTWARE.
;------------------------------------------------------------------------