| 4e987026 |
;;; pprint.scm -- xp pretty-printer in Scheme
;;;
;;; author : Sandra Loosemore
;;; date : 29 Oct 1991
;;;
;;;
;;; This code is adapted from the XP pretty printer originally written
;;; in Common Lisp by Dick Waters. Here is the copyright notice attached
;;; to the original XP source file:
;;;
;;;------------------------------------------------------------------------
;;;
;;; Copyright 1989,1990 by the 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.
;;;
;;;------------------------------------------------------------------------
;;;
;;;=====================================================================
;;; Variables
;;;=====================================================================
;;; External variables. These may be specially bound by user code.
(define *print-escape* '#t)
(define *print-circle* '#f)
(define *print-level* '#f)
(define *print-length* '#f)
(define *print-base* 10)
(define *print-radix* '#f)
(define *print-shared* '#f)
(define *print-pretty* '#f)
(define *print-right-margin* '#f)
(define *print-miser-width* 40)
(define *print-lines* '#f)
(define *default-right-margin* 70)
(define *last-abbreviated-printing*
(lambda maybe-stream
(declare (ignore maybe-stream))
'#f))
(define *print-dispatch* '#f) ; initialized later
(define *print-structure* '#f)
(define *print-structure-slots* '#t)
;;; *** These variables aren't really supported, but they should be.
(define *print-readably* '#f)
(define *print-case* 'upcase)
;;; Internal variables. These are all specially rebound when we initiate
;;; printing to an XP stream.
(define *xp.current-level* 0)
(define *xp.current-length* 0)
(define *xp.abbreviation-happened* '#f)
(define *xp.locating-circularities* '#f)
(define *xp.parents* '())
(define *xp.circularity-hash-table* '#f)
(define *xp.line-limit-abbreviation-exit*
(lambda values
(declare (ignore values))
(error "No line limit abbreviation exit in this extent.")))
;;;=====================================================================
;;; Dispatching
;;;=====================================================================
;;; Since Scheme doesn't have type specifiers or named structures,
;;; the dispatch mechanism defined for the Common Lisp XP won't work
;;; very well. A more general alternative might be to maintain a
;;; sorted list of <priority predicate printer> tuples, but having to
;;; try each of these in sequence could get very slow.
;;;
;;; What I've decided to to instead is to have the value of
;;; *print-dispatch* be a user-defined dispatcher
;;; function: given an object, it should return a function to print it,
;;; or #f. In the latter case, the object is printed in some default
;;; way.
;;;
;;; The standard dispatcher function is defined towards the bottom
;;; of this file. If you are writing your own dispatcher, you should
;;; probably call this function as the fall-through case.
(define (xp.get-printer object)
(funcall (dynamic *print-dispatch*) object))
;;;=====================================================================
;;; Internal data structures
;;;=====================================================================
(define-integrable xp.block-stack-entry-size 1)
(define-integrable xp.prefix-stack-entry-size 5)
(define-integrable xp.queue-entry-size 7)
(define-integrable xp.buffer-entry-size 1)
(define-integrable xp.prefix-entry-size 1)
(define-integrable xp.suffix-entry-size 1)
(define-integrable xp.block-stack-min-size (* 35 xp.block-stack-entry-size))
(define-integrable xp.prefix-stack-min-size (* 30 xp.prefix-stack-entry-size))
(define-integrable xp.queue-min-size (* 75 xp.queue-entry-size))
(define-integrable xp.buffer-min-size 256)
(define-integrable xp.prefix-min-size 256)
(define-integrable xp.suffix-min-size 256)
;;; The xp stream structure.
;;; Fields without defaults are initialized by xp.initialize-xp, below.
(define-struct xp
(prefix xp.)
(predicate xp.xp-structure-p)
(slots
(base-stream (type t) (default '#f))
(linel (type fixnum) (default 0))
(line-limit (type (maybe fixnum)) (default '#f))
(line-no (type fixnum) (default 0))
(char-mode (type (enum #f up down cap0 cap1 capw)) (default '#f))
(char-mode-counter (type fixnum) (default 0))
;; number of logical blocks at qright that are started but not ended.
(depth-in-blocks (type fixnum) (default 0))
;; This stack is pushed and popped in accordance with the way blocks
;; are nested at the moment they are entered into the queue.
(block-stack (type vector) (default (make-vector xp.block-stack-min-size)))
;; Pointer into block-stack vector.
(block-stack-ptr (type fixnum) (default 0))
;; This is a string that builds up the line images that will be printed out.
(buffer (type string) (default (make-string xp.buffer-min-size)))
;; The output character position of the first character in the buffer;
;; nonzero only if a partial line has been output.
(charpos (type fixnum) (default 0))
;; The index in the buffer where the next character is to be inserted.
(buffer-ptr (type fixnum) (default 0))
;; This 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.
(buffer-offset (type fixnum) (default 0))
;; The queue of action descriptors. The value is a vector.
(queue (type vector) (default (make-vector xp.queue-min-size)))
;; Index of next queue entry to dequeue.
(qleft (type fixnum) (default 0))
;; Index of last entry queued; queue is empty when (> qleft qright).
(qright (type fixnum) (default 0))
;; This stores the prefix that should be used at the start of the line.
(prefix (type string) (default (make-string xp.buffer-min-size)))
;; 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.
(prefix-stack (type vector) (default (make-vector xp.prefix-stack-min-size)))
;; Index into prefix-stack.
(prefix-stack-ptr (type fixnum) (default 0))
;; This stores the suffixes that have to be pritned to close of the
;; current open blocks. For convenience in popping, the whole suffix
;; is stored in reverse order.
(suffix (type string) (default (make-string xp.buffer-min-size)))
))
(define (xp.make-xp-structure)
(make xp))
;;; Positions within the buffer are kept in three 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.
(define-local-syntax (xp.lp<-bp xp . maybe-ptr)
(let ((ptr (if (not (null? maybe-ptr))
(car maybe-ptr)
`(xp.buffer-ptr ,xp))))
`(+ ,ptr (xp.charpos ,xp))))
(define-local-syntax (xp.tp<-bp xp)
`(+ (xp.buffer-ptr ,xp) (xp.buffer-offset ,xp)))
(define-local-syntax (xp.bp<-lp xp ptr)
`(- ,ptr (xp.charpos ,xp)))
(define-local-syntax (xp.bp<-tp xp ptr)
`(- ,ptr (xp.buffer-offset ,xp)))
(define-local-syntax (xp.lp<-tp xp ptr)
`(xp.lp<-bp ,xp (xp.bp<-tp ,xp ,ptr)))
;;; Define some macros for growing the various stacks in the xp-structure.
(define-local-syntax (xp.check-block-stack-size xp ptr)
`(setf (xp.block-stack ,xp)
(xp.grow-vector (xp.block-stack ,xp) ,ptr xp.block-stack-entry-size)))
(define-local-syntax (xp.check-prefix-size xp ptr)
`(setf (xp.prefix ,xp)
(xp.grow-string (xp.prefix ,xp) ,ptr xp.prefix-entry-size)))
(define-local-syntax (xp.check-prefix-stack-size xp ptr)
`(setf (xp.prefix-stack ,xp)
(xp.grow-vector (xp.prefix-stack ,xp) ,ptr xp.prefix-stack-entry-size)))
(define-local-syntax (xp.check-queue-size xp ptr)
`(setf (xp.queue ,xp)
(xp.grow-vector (xp.queue ,xp) ,ptr xp.queue-entry-size)))
(define-local-syntax (xp.check-buffer-size xp ptr)
`(setf (xp.buffer ,xp)
(xp.grow-string (xp.buffer ,xp) ,ptr xp.buffer-entry-size)))
(define-local-syntax (xp.check-suffix-size xp ptr)
`(setf (xp.suffix ,xp)
(xp.grow-string (xp.suffix ,xp) ,ptr xp.suffix-entry-size)))
(define (xp.grow-vector old ptr entry-size)
(let ((end (vector-length old)))
(if (> ptr (- end entry-size))
(let ((new (make-vector (+ ptr 50))))
(dotimes (i end)
(setf (vector-ref new i) (vector-ref old i)))
new)
old)))
(define (xp.grow-string old ptr entry-size)
(let ((end (string-length old)))
(if (> ptr (- end entry-size))
(let ((new (make-string (+ ptr 50))))
(dotimes (i end)
(setf (string-ref new i) (string-ref old i)))
new)
old)))
;;; Things for manipulating the block stack.
(define-local-syntax (xp.section-start xp)
`(vector-ref (xp.block-stack ,xp) (xp.block-stack-ptr ,xp)))
(define (xp.push-block-stack xp)
(incf (xp.block-stack-ptr xp) xp.block-stack-entry-size)
(xp.check-block-stack-size xp (xp.block-stack-ptr xp)))
(define (xp.pop-block-stack xp)
(decf (xp.block-stack-ptr xp) xp.block-stack-entry-size))
;;; Prefix stack manipulations
(define-local-syntax (xp.prefix-ptr xp)
`(vector-ref (xp.prefix-stack ,xp) (xp.prefix-stack-ptr ,xp)))
(define-local-syntax (xp.suffix-ptr xp)
`(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 1)))
(define-local-syntax (non-blank-prefix-ptr xp)
`(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 2)))
(define-local-syntax (initial-prefix-ptr xp)
`(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 3)))
(define-local-syntax (xp.section-start-line xp)
`(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 4)))
(define (xp.push-prefix-stack xp)
(let ((old-prefix 0)
(old-suffix 0)
(old-non-blank 0))
(when (not (negative? (xp.prefix-stack-ptr xp)))
(setf old-prefix (xp.prefix-ptr xp))
(setf old-suffix (xp.suffix-ptr xp))
(setf old-non-blank (non-blank-prefix-ptr xp)))
(incf (xp.prefix-stack-ptr xp) xp.prefix-stack-entry-size)
(xp.check-prefix-stack-size xp (xp.prefix-stack-ptr xp))
(setf (xp.prefix-ptr xp) old-prefix)
(setf (xp.suffix-ptr xp) old-suffix)
(setf (non-blank-prefix-ptr xp) old-non-blank)))
(define (xp.pop-prefix-stack xp)
(decf (xp.prefix-stack-ptr xp) xp.prefix-stack-entry-size))
;;; 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.
(define-local-syntax (xp.qtype xp index)
`(vector-ref (xp.queue ,xp) ,index))
(define-local-syntax (xp.qkind xp index)
`(vector-ref (xp.queue ,xp) (1+ ,index)))
(define-local-syntax (xp.qpos xp index)
`(vector-ref (xp.queue ,xp) (+ ,index 2)))
(define-local-syntax (xp.qdepth xp index)
`(vector-ref (xp.queue ,xp) (+ ,index 3)))
(define-local-syntax (xp.qend xp index)
`(vector-ref (xp.queue ,xp) (+ ,index 4)))
(define-local-syntax (xp.qoffset xp index)
`(vector-ref (xp.queue ,xp) (+ ,index 5)))
(define-local-syntax (xp.qarg xp index)
`(vector-ref (xp.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.
(define (xp.enqueue xp type kind . maybe-arg)
(incf (xp.qright xp) xp.queue-entry-size)
(when (> (xp.qright xp) (- xp.queue-min-size xp.queue-entry-size))
(vector-replace (xp.queue xp) (xp.queue xp) 0 (xp.qleft xp) (xp.qright xp))
(setf (xp.qright xp) (- (xp.qright xp) (xp.qleft xp)))
(setf (xp.qleft xp) 0))
(xp.check-queue-size xp (xp.qright xp))
(setf (xp.qtype xp (xp.qright xp)) type)
(setf (xp.qkind xp (xp.qright xp)) kind)
(setf (xp.qpos xp (xp.qright xp)) (xp.tp<-bp xp))
(setf (xp.qdepth xp (xp.qright xp)) (xp.depth-in-blocks xp))
(setf (xp.qend xp (xp.qright xp)) '#f)
(setf (xp.qoffset xp (xp.qright xp)) '#f)
(setf (xp.qarg xp (xp.qright xp)) (car maybe-arg)))
(define-local-syntax (xp.qnext index) `(+ ,index xp.queue-entry-size))
;;; Print routine for xp structures
;;; *** this is broken, it uses unimplemented format options.
(define *xp.describe-xp-streams-fully* '#f)
(define (xp.describe-xp xp . maybe-stream)
(let ((s (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(format s "#<XP stream ")
(if (not (xp.base-stream xp))
(format s "not currently in use")
(begin
(format s "outputting to ~S" (xp.base-stream xp))
(format s "~&buffer= ~S"
(substring (xp.buffer xp) 0 (max (xp.buffer-ptr xp) 0)))
(if (not (dynamic *xp.describe-xp-streams-fully*))
(format s " ...")
(begin
(format s "~& pos _123456789_123456789_123456789_123456789")
(format s "~&depth-in-blocks= ~D linel= ~D line-no= ~D line-limit= ~D"
(xp.depth-in-blocks xp) (xp.linel xp)
(xp.line-no xp) (xp.line-limit xp))
(when (or (xp.char-mode xp) (not (zero? (xp.char-mode-counter xp))))
(format s "~&char-mode= ~S char-mode-counter= ~D"
(xp.char-mode xp) (xp.char-mode-counter xp)))
(unless (negative? (xp.block-stack-ptr xp))
(format s "~§ion-start")
(do ((save (xp.block-stack-ptr xp)))
((negative? (xp.block-stack-ptr xp))
(setf (xp.block-stack-ptr xp) save))
(format s " ~D" (xp.section-start xp))
(xp.pop-block-stack xp)))
(format s "~&linel= ~D charpos= ~D buffer-ptr= ~D buffer-offset= ~D"
(xp.linel xp) (xp.charpos xp)
(xp.buffer-ptr xp) (xp.buffer-offset xp))
(unless (negative? (xp.prefix-stack-ptr xp))
(format s "~&prefix= ~S"
(substring (xp.prefix xp) 0 (max (xp.prefix-ptr xp) 0)))
(format s "~&suffix= ~S"
(substring (xp.suffix xp) 0 (max (xp.suffix-ptr xp) 0))))
(unless (> (xp.qleft xp) (xp.qright xp))
(format s "~&ptr type kind pos depth end offset arg")
(do ((p (xp.qleft xp) (xp.qnext p)))
((> p (xp.qright xp)))
(format s "~&~4A~13A~15A~4A~6A~4A~7A~A"
(/ (- p (xp.qleft xp)) xp.queue-entry-size)
(xp.qtype xp p)
(if (memq (xp.qtype xp p) '(newline ind))
(xp.qkind xp p)
"")
(xp.bp<-tp xp (xp.qpos xp p))
(xp.qdepth xp p)
(if (not (memq (xp.qtype xp p)
'(newline start-block)))
""
(and (xp.qend xp p)
(/ (- (+ p (xp.qend xp p)) (xp.qleft xp))
xp.queue-entry-size)))
(if (not (eq? (xp.qtype xp p) 'start-block))
""
(and (xp.qoffset xp p)
(/ (- (+ p (xp.qoffset xp p)) (xp.qleft xp))
xp.queue-entry-size)))
(if (not (memq (xp.qtype xp p)
'(ind start-block end-block)))
""
(xp.qarg xp p)))))
(unless (negative? (xp.prefix-stack-ptr xp))
(format s "~&initial-prefix-ptr prefix-ptr suffix-ptr non-blank start-line")
(do ((save (xp.prefix-stack-ptr xp)))
((negative? (xp.prefix-stack-ptr xp))
(setf (xp.prefix-stack-ptr xp) save))
(format s "~& ~19A~11A~11A~10A~A"
(initial-prefix-ptr xp)
(xp.prefix-ptr xp)
(xp.suffix-ptr xp)
(non-blank-prefix-ptr xp)
(xp.section-start-line xp))
(xp.pop-prefix-stack xp)))))))
(format s ">")))
;;; Allocation of XP structures
;;; This maintains a list of XP structures. We save them
;;; so that we don't have to create new ones all of the time.
;;; We have separate objects so that many can be in use at once
;;; (e.g. for printing to multiple streams).
(define xp.free-xps '())
(define (xp.get-pretty-print-stream stream)
(xp.initialize-xp
(if (not (null? xp.free-xps))
(pop xp.free-xps)
(xp.make-xp-structure))
stream))
;;; If you call this, the xp-stream gets efficiently recycled.
(define (xp.free-pretty-print-stream xp)
(setf (xp.base-stream xp) '#f)
(if (not (memq xp xp.free-xps))
(push xp xp.free-xps)))
;;; This is called to initialize things when you start pretty printing.
(define (xp.initialize-xp xp stream)
(setf (xp.base-stream xp) stream)
(setf (xp.linel xp)
(max 0
(cond ((dynamic *print-right-margin*))
((internal-output-width stream))
(else (dynamic *default-right-margin*)))))
(setf (xp.line-limit xp) (dynamic *print-lines*))
(setf (xp.line-no xp) 1)
(setf (xp.char-mode xp) '#f)
(setf (xp.char-mode-counter xp) 0)
(setf (xp.depth-in-blocks xp) 0)
(setf (xp.block-stack-ptr xp) 0)
(setf (xp.charpos xp) (or (internal-output-position stream) 0))
(setf (xp.section-start xp) 0)
(setf (xp.buffer-ptr xp) 0)
(setf (xp.buffer-offset xp) (xp.charpos xp))
(setf (xp.qleft xp) 0)
(setf (xp.qright xp) (- xp.queue-entry-size))
(setf (xp.prefix-stack-ptr xp) (- xp.prefix-stack-entry-size))
xp)
;;; The char-mode stuff is a bit tricky.
;;; one can be in one of the following modes:
;;; NIL no changes to characters output.
;;; :UP CHAR-UPCASE used.
;;; :DOWN CHAR-DOWNCASE used.
;;; :CAP0 capitalize next alphanumeric letter then switch to :DOWN.
;;; :CAP1 capitalize next alphanumeric letter then switch to :CAPW
;;; :CAPW downcase letters. When a word break letter found, switch to :CAP1.
;;; It is possible for ~(~) to be nested in a format string, but note that
;;; each mode specifies what should happen to every letter. Therefore, inner
;;; nested modes never have any effect. You can just ignore them.
(define (xp.push-char-mode xp new-mode)
(if (zero? (xp.char-mode-counter xp))
(setf (xp.char-mode xp) new-mode))
(incf (xp.char-mode-counter xp)))
(define (xp.pop-char-mode xp)
(decf (xp.char-mode-counter xp))
(if (zero? (xp.char-mode-counter xp))
(setf (xp.char-mode xp) '#f)))
;;; Assumes is only called when char-mode is non-nil
(define (xp.handle-char-mode xp char)
(case (xp.char-mode xp)
((CAP0)
(cond ((not (or (char-alphabetic? char) (char-numeric? char))) char)
(else (setf (xp.char-mode xp) 'DOWN) (char-upcase char))))
((CAP1)
(cond ((not (or (char-alphabetic? char) (char-numeric? char))) char)
(else (setf (xp.char-mode xp) 'CAPW) (char-upcase char))))
((CAPW)
(cond ((or (char-alphabetic? char) (char-numeric? char))
(char-downcase char))
(else (setf (xp.char-mode xp) 'CAP1) char)))
((UP)
(char-upcase char))
(else
(char-downcase char)))) ;DOWN
;;; All characters output are passed through the handler above. However,
;;; it must be noted that on-each-line prefixes are only processed in the
;;; context of the first place they appear. They stay the same later no
;;; matter what. Also non-literal newlines do not count as word breaks.
;;; 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.
(define (xp.write-char+ char xp)
(if (eqv? char #\newline)
(xp.pprint-newline+ 'unconditional xp)
(xp.write-char++ char xp)))
(define (xp.write-string+ mystring xp start end)
(let ((next-newline (string-position #\newline mystring start end)))
(if next-newline
(begin
(xp.write-string++ mystring xp start next-newline)
(xp.pprint-newline+ 'unconditional xp)
(xp.write-string+ mystring xp (1+ next-newline) end))
(xp.write-string++ mystring xp start end))))
;;; note this checks (> BUFFER-PTR LINEL) instead of (> (xp.lp<-bp) LINEL)
;;; this is important so that when things are longer than a line they
;;; end up getting printed in chunks of size LINEL.
(define (xp.write-char++ char xp)
(when (> (xp.buffer-ptr xp) (xp.linel xp))
(xp.force-some-output xp))
(let ((new-buffer-end (1+ (xp.buffer-ptr xp))))
(xp.check-buffer-size xp new-buffer-end)
(if (xp.char-mode xp) (setf char (xp.handle-char-mode xp char)))
(setf (string-ref (xp.buffer xp) (xp.buffer-ptr xp)) char)
(setf (xp.buffer-ptr xp) new-buffer-end)))
(define (xp.force-some-output xp)
(xp.attempt-to-output xp '#f '#f)
(when (> (xp.buffer-ptr xp) (xp.linel xp)) ;only if printing off end of line
(xp.attempt-to-output xp '#t '#t)))
(define (xp.write-string++ mystring xp start end)
(when (> (xp.buffer-ptr xp) (xp.linel xp))
(xp.force-some-output xp))
(xp.write-string+++ mystring xp start end))
;;; never forces output; therefore safe to call from within xp.output-line.
(define (xp.write-string+++ mystring xp start end)
(let ((new-buffer-end (+ (xp.buffer-ptr xp) (- end start))))
(xp.check-buffer-size xp new-buffer-end)
(do ((buffer (xp.buffer xp))
(i (xp.buffer-ptr xp) (1+ i))
(j start (1+ j)))
((= j end))
(let ((char (string-ref mystring j)))
(if (xp.char-mode xp) (setf char (xp.handle-char-mode xp char)))
(setf (string-ref buffer i) char)))
(setf (xp.buffer-ptr xp) new-buffer-end)))
(define (xp.pprint-tab+ kind colnum colinc xp)
(let ((indented? '#f)
(relative? '#f))
(case kind
((section) (setf indented? '#t))
((line-relative) (setf relative? '#t))
((section-relative) (setf indented? '#t) (setf relative? '#t)))
(let* ((current
(if (not indented?)
(xp.lp<-bp xp)
(- (xp.tp<-bp xp) (xp.section-start xp))))
(new
(if (zero? colinc)
(if relative? (+ current colnum) (max colnum current))
(cond (relative?
(* colinc
(quotient (+ current colnum colinc -1) colinc)))
((> colnum current) colnum)
(else
(+ colnum
(* colinc
(quotient (+ current (- colnum) colinc)
colinc)))))))
(end (- new current)))
(when (positive? end)
(if (xp.char-mode xp) (xp.handle-char-mode xp #\space))
(let ((end (+ (xp.buffer-ptr xp) end)))
(xp.check-buffer-size xp end)
(string-fill (xp.buffer xp) #\space (xp.buffer-ptr xp) end)
(setf (xp.buffer-ptr xp) end))))))
;;; note following is smallest number >= x that is a multiple of colinc
;;; (* colinc (quotient (+ x (1- colinc)) colinc))
(define (xp.pprint-newline+ kind xp)
(xp.enqueue xp 'newline kind)
(do ((ptr (xp.qleft xp) (xp.qnext ptr))) ;find sections we are ending
((not (< ptr (xp.qright xp)))) ;all but last
(when (and (not (xp.qend xp ptr))
(not (> (xp.depth-in-blocks xp) (xp.qdepth xp ptr)))
(memq (xp.qtype xp ptr) '(newline start-block)))
(setf (xp.qend xp ptr) (- (xp.qright xp) ptr))))
(setf (xp.section-start xp) (xp.tp<-bp xp))
(when (and (memq kind '(fresh unconditional)) (xp.char-mode xp))
(xp.handle-char-mode xp #\newline))
(when (memq kind '(fresh unconditional mandatory))
(xp.attempt-to-output xp '#t '#f)))
(define (xp.start-block xp prefix-string on-each-line? suffix-string)
(xp.write-prefix-suffix prefix-string xp)
(if (and (xp.char-mode xp) on-each-line?)
(setf prefix-string
(substring (xp.buffer xp)
(- (xp.buffer-ptr xp) (string-length prefix-string))
(xp.buffer-ptr xp))))
(xp.push-block-stack xp)
(xp.enqueue xp 'start-block '#f
(if on-each-line? (cons suffix-string prefix-string) suffix-string))
(incf (xp.depth-in-blocks xp)) ;must be after enqueue
(setf (xp.section-start xp) (xp.tp<-bp xp)))
(define (xp.end-block xp suffix)
(unless (and (dynamic *xp.abbreviation-happened*)
(eqv? (dynamic *xp.abbreviation-happened*)
(dynamic *print-lines*)))
(xp.write-prefix-suffix suffix xp)
(decf (xp.depth-in-blocks xp))
(xp.enqueue xp 'end-block '#f suffix)
(block foundit
(do ((ptr (xp.qleft xp) (xp.qnext ptr))) ;look for start of block we are ending
((not (< ptr (xp.qright xp)))) ;all but last
(when (and (= (xp.depth-in-blocks xp) (xp.qdepth xp ptr))
(eq? (xp.qtype xp ptr) 'start-block)
(not (xp.qoffset xp ptr)))
(setf (xp.qoffset xp ptr) (- (xp.qright xp) ptr))
(return-from foundit '#f))) ;can only be 1
)
(xp.pop-block-stack xp)))
(define (xp.write-prefix-suffix mystring xp)
(when mystring
(xp.write-string++ mystring xp 0 (string-length mystring))))
(define (xp.pprint-indent+ kind n xp)
(xp.enqueue xp 'ind kind n))
;;; attempt-to-output 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.
;;; 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.
(define-local-syntax (xp.maybe-too-large xp Qentry)
`(let ((limit (xp.linel ,xp)))
(when (eqv? (xp.line-limit ,xp) (xp.line-no ,xp)) ;prevents suffix overflow
(decf limit 2) ;3 for " .." minus 1 for space (heuristic)
(when (not (negative? (xp.prefix-stack-ptr ,xp)))
(decf limit (xp.suffix-ptr ,xp))))
(cond ((xp.qend ,xp ,Qentry)
(> (xp.lp<-tp ,xp (xp.qpos ,xp (+ ,Qentry (xp.qend ,xp ,Qentry)))) limit))
((or force-newlines? (> (xp.lp<-bp ,xp) limit))
'#t)
(else ;wait until later to decide.
(return-from attempt-to-output '#f)))))
(define-local-syntax (xp.misering? xp)
`(and (dynamic *print-miser-width*)
(<= (- (xp.linel ,xp) (initial-prefix-ptr ,xp))
(dynamic *print-miser-width*))))
(define (xp.attempt-to-output xp force-newlines? flush-out?)
(block attempt-to-output
(do ()
((> (xp.qleft xp) (xp.qright xp))
(setf (xp.qleft xp) 0)
(setf (xp.qright xp) (- xp.queue-entry-size))) ;saves shifting
(case (xp.qtype xp (xp.qleft xp))
((ind)
(unless (xp.misering? xp)
(xp.set-indentation-prefix
xp
(case (xp.qkind xp (xp.qleft xp))
((block)
(+ (initial-prefix-ptr xp) (xp.qarg xp (xp.qleft xp))))
(else ; current
(+ (xp.lp<-tp xp (xp.qpos xp (xp.qleft xp)))
(xp.qarg xp (xp.qleft xp)))))))
(setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))
((start-block)
(cond ((xp.maybe-too-large xp (xp.qleft xp))
(xp.push-prefix-stack xp)
(setf (initial-prefix-ptr xp) (xp.prefix-ptr xp))
(xp.set-indentation-prefix
xp (xp.lp<-tp xp (xp.qpos xp (xp.qleft xp))))
(let ((arg (xp.qarg xp (xp.qleft xp))))
(when (pair? arg) (xp.set-prefix xp (cdr arg)))
(setf (initial-prefix-ptr xp) (xp.prefix-ptr xp))
(cond ((not (list? arg)) (xp.set-suffix xp arg))
((car arg) (xp.set-suffix xp (car arg)))))
(setf (xp.section-start-line xp) (xp.line-no xp)))
(else (incf (xp.qleft xp) (xp.qoffset xp (xp.qleft xp)))))
(setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))
((end-block)
(xp.pop-prefix-stack xp)
(setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))
(else ; newline
(when (case (xp.qkind xp (xp.qleft xp))
((fresh) (not (zero? (xp.lp<-bp xp))))
((miser) (xp.misering? xp))
((fill) (or (xp.misering? xp)
(> (xp.line-no xp) (xp.section-start-line xp))
(xp.maybe-too-large xp (xp.qleft xp))))
(else '#t)) ;(linear unconditional mandatory)
(xp.output-line xp (xp.qleft xp))
(xp.setup-for-next-line xp (xp.qleft xp)))
(setf (xp.qleft xp) (xp.qnext (xp.qleft xp)))))))
(when flush-out? (xp.flush xp)))
;;; this can only be called last!
(define (xp.flush xp)
(unless (dynamic *xp.locating-circularities*)
(internal-write-string (xp.buffer xp) (xp.base-stream xp) 0 (xp.buffer-ptr xp)))
(incf (xp.buffer-offset xp) (xp.buffer-ptr xp))
(incf (xp.charpos xp) (xp.buffer-ptr xp))
(setf (xp.buffer-ptr xp) 0))
;;; This prints out a line of stuff.
(define (xp.output-line xp Qentry)
(let* ((out-point (xp.bp<-tp xp (xp.qpos xp Qentry)))
(last-non-blank (string-position-not-from-end
#\space (xp.buffer xp) 0 out-point))
(end (cond ((memq (xp.qkind xp Qentry) '(fresh unconditional))
out-point)
(last-non-blank (1+ last-non-blank))
(else 0)))
(line-limit-exit (and (xp.line-limit xp)
(not (> (xp.line-limit xp) (xp.line-no xp))))))
(when line-limit-exit
(setf (xp.buffer-ptr xp) end) ;truncate pending output.
(xp.write-string+++ " .." xp 0 3)
(string-nreverse (xp.suffix xp) 0 (xp.suffix-ptr xp))
(xp.write-string+++ (xp.suffix xp) xp 0 (xp.suffix-ptr xp))
(setf (xp.qleft xp) (xp.qnext (xp.qright xp)))
(setf (dynamic *xp.abbreviation-happened*) (dynamic *print-lines*))
(funcall (dynamic *xp.line-limit-abbreviation-exit*) '#t))
(incf (xp.line-no xp))
(unless (dynamic *xp.locating-circularities*)
(internal-write-string (xp.buffer xp) (xp.base-stream xp) 0 end)
(newline (xp.base-stream xp)))))
(define (xp.setup-for-next-line xp Qentry)
(let* ((out-point (xp.bp<-tp xp (xp.qpos xp Qentry)))
(prefix-end
(cond ((memq (xp.qkind xp Qentry) '(unconditional fresh))
(non-blank-prefix-ptr xp))
(else (xp.prefix-ptr xp))))
(change (- prefix-end out-point)))
(setf (xp.charpos xp) 0)
(when (positive? change) ;almost never happens
(xp.check-buffer-size xp (+ (xp.buffer-ptr xp) change)))
(string-replace (xp.buffer xp) (xp.buffer xp)
prefix-end out-point (xp.buffer-ptr xp))
(string-replace (xp.buffer xp) (xp.prefix xp) 0 0 prefix-end)
(incf (xp.buffer-ptr xp) change)
(decf (xp.buffer-offset xp) change)
(when (not (memq (xp.qkind xp Qentry) '(unconditional fresh)))
(setf (xp.section-start-line xp) (xp.line-no xp)))))
(define (xp.set-indentation-prefix xp new-position)
(let ((new-ind (max (non-blank-prefix-ptr xp) new-position)))
(setf (xp.prefix-ptr xp) (initial-prefix-ptr xp))
(xp.check-prefix-size xp new-ind)
(when (> new-ind (xp.prefix-ptr xp))
(string-fill (xp.prefix xp) #\space (xp.prefix-ptr xp) new-ind))
(setf (xp.prefix-ptr xp) new-ind)))
(define (xp.set-prefix xp prefix-string)
(let ((end (string-length prefix-string)))
(string-replace (xp.prefix xp) prefix-string
(- (xp.prefix-ptr xp) end) 0 end))
(setf (non-blank-prefix-ptr xp) (xp.prefix-ptr xp)))
(define (xp.set-suffix xp suffix-string)
(let* ((end (string-length suffix-string))
(new-end (+ (xp.suffix-ptr xp) end)))
(xp.check-suffix-size xp new-end)
(do ((i (1- new-end) (1- i))
(j 0 (1+ j)))
((= j end))
(setf (string-ref (xp.suffix xp) i) (string-ref suffix-string j)))
(setf (xp.suffix-ptr xp) new-end)))
;;;=====================================================================
;;; Basic interface functions
;;;=====================================================================
;;; The internal functions in this file
;;; 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.
(define (write object . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(cond ((xp.xp-structure-p stream)
(xp.write+ object stream))
((xp.get-printer object)
(xp.initiate-xp-printing
(lambda (s o) (xp.write+ o s))
stream
object))
(else
(internal-write object stream)))))
(define (xp.maybe-initiate-xp-printing fn stream . args)
(if (xp.xp-structure-p stream)
(apply fn stream args)
(apply (function xp.initiate-xp-printing) fn stream args)))
(define (xp.initiate-xp-printing fn stream . args)
(dynamic-let ((*xp.abbreviation-happened*
'#f)
(*xp.locating-circularities*
(if (dynamic *print-circle*)
0
'#f))
(*xp.circularity-hash-table*
(if (dynamic *print-circle*)
(make-table)
'#f))
(*xp.parents*
(if (not (dynamic *print-shared*))
(list '#f)
'())) ;*** is this right?
(*xp.current-level*
0)
(*xp.current-length*
0))
(let ((result (xp.xp-print fn stream args)))
(when (dynamic *xp.abbreviation-happened*)
(setf args (list-copy args))
(setf (dynamic *last-abbreviated-printing*)
(lambda maybe-stream
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
stream)))
(apply (function xp.maybe-initiate-xp-printing)
fn stream args)))))
result)))
(define (xp.xp-print fn stream args)
(let ((result (xp.do-xp-printing fn stream args)))
(when (dynamic *xp.locating-circularities*)
(setf (dynamic *xp.locating-circularities*) '#f)
(setf (dynamic *xp.abbreviation-happened*) '#f)
(setf (dynamic *xp.parents*) '())
(setf result (xp.do-xp-printing fn stream args)))
result))
(define (xp.do-xp-printing fn stream args)
(let ((xp (xp.get-pretty-print-stream stream))
(result '#f))
(dynamic-let ((*xp.current-level* 0))
(let/cc catch
(dynamic-let ((*xp.line-limit-abbreviation-exit* catch))
(xp.start-block xp '#f '#f '#f)
(setf result (apply fn xp args))
(xp.end-block xp '#f)))
(when (and (dynamic *xp.locating-circularities*)
(zero? (dynamic *xp.locating-circularities*)) ;No circularities.
(= (xp.line-no xp) 1) ;Didn't suppress line.
(zero? (xp.buffer-offset xp))) ;Didn't suppress partial line.
(setf (dynamic *xp.locating-circularities*) '#f)) ;print what you have got.
(when (let/cc catch
(dynamic-let ((*xp.line-limit-abbreviation-exit* catch))
(xp.attempt-to-output xp '#f '#t)
'#f))
(xp.attempt-to-output xp '#t '#t))
(xp.free-pretty-print-stream xp)
result)))
(define (xp.write+ object xp)
(dynamic-let ((*xp.parents* (dynamic *xp.parents*)))
(unless (and (dynamic *xp.circularity-hash-table*)
(eq? (xp.circularity-process xp object '#f) 'subsequent))
(when (and (dynamic *xp.circularity-hash-table*) (pair? object))
;; Must do this to avoid additional circularity detection by
;; pprint-logical-block; otherwise you get stuff like #1=#1#.
(setf object (cons (car object) (cdr object))))
(funcall (or (xp.get-printer object) (function xp.print-default))
object
xp))
object))
(define (xp.print-default object xp)
(let ((stuff (internal-write-to-string object)))
(xp.write-string+ stuff xp 0 (string-length stuff))))
;;; It is vital that this function be called EXACTLY once for each occurrence
;;; of each thing in something being printed.
;;; Returns nil if printing should just continue on.
;;; Either it is not a duplicate, or we are in the first pass and do not
;;; know.
;;; returns :FIRST if object is first occurrence of a DUPLICATE.
;;; (This can only be returned on a second pass.)
;;; After an initial code (printed by this routine on the second pass)
;;; printing should continue on for the object.
;;; returns :SUBSEQUENT if second or later occurrence.
;;; Printing is all taken care of by this routine.
;;; Note many (maybe most) lisp implementations have characters and small
;;; numbers represented in a single word so that the are always eq when
;;; they are equal and the reader takes care of properly sharing them
;;; (just as it does with symbols). Therefore, we do not want circularity
;;; processing applied to them. However, some kinds of numbers
;;; (e.g., bignums) undoubtedly are complex structures that the reader
;;; does not share. However, they cannot have circular pointers in them
;;; and it is therefore probably a waste to do circularity checking on them.
;;; In any case, it is not clear that it easy to tell exactly what kinds of
;;; numbers a given implementation is going to have the reader
;;; automatically share.
(define (xp.circularity-process xp object interior-cdr?)
(unless (or (number? object)
(char? object)
(and (symbol? object) (not (gensym? object))))
(let ((id (table-entry (dynamic *xp.circularity-hash-table*) object)))
(if (dynamic *xp.locating-circularities*)
;; This is the first pass.
(cond ((not id) ;never seen before
(when (not (null? (dynamic *xp.parents*)))
(push object (dynamic *xp.parents*)))
(setf (table-entry (dynamic *xp.circularity-hash-table*) object)
0)
'#f)
((zero? id) ;possible second occurrence
(cond ((or (null? (dynamic *xp.parents*))
(memq object (dynamic *xp.parents*)))
(setf (table-entry
(dynamic *xp.circularity-hash-table*) object)
(incf (dynamic *xp.locating-circularities*)))
'subsequent)
(else '#f)))
(else 'subsequent));third or later occurrence
;; This is the second pass.
(cond ((or (not id) ;never seen before (note ~@* etc. conses)
(zero? id));no duplicates
'#f)
((positive? id) ; first occurrence
(cond (interior-cdr?
(decf (dynamic *xp.current-level*))
(xp.write-string++ ". #" xp 0 3))
(else (xp.write-char++ #\# xp)))
(xp.print-integer id xp)
(xp.write-char++ #\= xp)
(setf (table-entry (dynamic *xp.circularity-hash-table*) object)
(- id))
'first)
(else
(if interior-cdr?
(xp.write-string++ ". #" xp 0 3)
(xp.write-char++ #\# xp))
(xp.print-integer(- id) xp)
(xp.write-char++ #\# xp)
'subsequent))))))
;;; Here are all the standard Common Lisp printing functions.
(define (print object . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(dynamic-let ((*print-escape* '#t))
(terpri stream)
(write object stream)
(write-char #\space stream)
object)))
(define (prin1 object . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(dynamic-let ((*print-escape* '#t))
(write object stream)
object)))
(define (princ object . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(dynamic-let ((*print-escape* '#f))
(write object stream)
object)))
(define (display object . maybe-stream)
(apply (function princ) object maybe-stream))
(define (pprint object . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(dynamic-let ((*print-escape* '#t)
(*print-pretty* '#t))
(terpri stream)
(write object stream)
(values))))
(define (prin1-to-string object)
(call-with-output-string
(lambda (stream)
(dynamic-let ((*print-escape* '#t))
(write object stream)))))
(define (princ-to-string object)
(call-with-output-string
(lambda (stream)
(dynamic-let ((*print-escape* '#f))
(write object stream)))))
(define (write-char char . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(if (xp.xp-structure-p stream)
(xp.write-char+ char stream)
(internal-write-char char stream))
char))
(define (write-string mystring . maybe-stream-start-end)
(let* ((stream (if (not (null? maybe-stream-start-end))
(car maybe-stream-start-end)
(current-output-port)))
(start (if (not (null? (cdr maybe-stream-start-end)))
(cadr maybe-stream-start-end)
0))
(end (if (not (null? (cddr maybe-stream-start-end)))
(caddr maybe-stream-start-end)
(string-length mystring))))
(if (xp.xp-structure-p stream)
(xp.write-string+ mystring stream start end)
(internal-write-string mystring stream start end))
mystring))
(define (write-line mystring . maybe-stream-start-end)
(let* ((stream (if (not (null? maybe-stream-start-end))
(car maybe-stream-start-end)
(current-output-port)))
(start (if (not (null? (cdr maybe-stream-start-end)))
(cadr maybe-stream-start-end)
0))
(end (if (not (null? (cddr maybe-stream-start-end)))
(caddr maybe-stream-start-end)
(string-length mystring))))
(if (xp.xp-structure-p stream)
(begin
(xp.write-string+ mystring stream start end)
(xp.pprint-newline+ 'unconditional stream))
(begin
(internal-write-string mystring stream start end)
(internal-newline stream)))
mystring))
(define (terpri . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(if (xp.xp-structure-p stream)
(xp.pprint-newline+ 'unconditional stream)
(internal-newline stream))
'#f))
(define (newline . maybe-stream)
(apply (function terpri) maybe-stream))
;;; 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.
(define (fresh-line . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(cond ((xp.xp-structure-p stream)
(xp.attempt-to-output stream '#t '#t) ;ok because we want newline
(when (not (zero? (xp.lp<-bp stream)))
(xp.pprint-newline+ 'fresh stream)
'#t))
(else
(internal-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.
(define (finish-output . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(if (xp.xp-structure-p stream)
(xp.attempt-to-output stream '#t '#t)
(internal-finish-output stream))
'#f))
(define (force-output . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(if (xp.xp-structure-p stream)
(xp.attempt-to-output stream '#t '#t)
(internal-force-output stream))
'#f))
(define (clear-output . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(if (xp.xp-structure-p stream)
(dynamic-let ((*xp.locating-circularities* 0)) ;hack to prevent visible output
(xp.attempt-to-output stream '#t '#t)
(internal-clear-output stream)))
'#f))
;;;=====================================================================
;;; Functional interface to dynamic formatting
;;;=====================================================================
;;; 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.
(define-syntax (pprint-logical-block stream-symbol-stuff . body)
(let* ((stream-symbol (car stream-symbol-stuff))
(mylist (cadr stream-symbol-stuff))
(rest (cddr stream-symbol-stuff))
(prefix (if (not (null? rest)) (pop rest) ""))
(suffix (if (not (null? rest)) (pop rest) ""))
(per-line? (if (not (null? rest)) (pop rest) '#f)))
`(xp.maybe-initiate-xp-printing
(lambda (,stream-symbol)
(let ((+l ,mylist)
(+p ,prefix)
(+s ,suffix)
(+x ,stream-symbol))
(xp.pprint-logical-block+ (+x +l +p +s ,per-line? '#t '#f)
,@body
'#f)))
,stream-symbol)))
;;; Assumes var and args must be variables. Other arguments must be literals
;;; or variables.
(define-syntax (xp.pprint-logical-block+ stuff . body)
(let* ((var (pop stuff))
(args (pop stuff))
(prefix (pop stuff))
(suffix (pop stuff))
(per-line? (pop stuff)))
`(unless (xp.check-abbreviation ,var ,args)
(dynamic-let ((*xp.current-level* (1+ (dynamic *xp.current-level*)))
(*xp.current-length* -1)
(*xp.parents* (dynamic *xp.parents*)))
(block logical-block
(if (dynamic *print-pretty*)
(xp.start-block ,var ,prefix ,per-line? ,suffix)
(xp.write-prefix-suffix ,prefix ,var))
(unwind-protect
(begin ,@body)
(if (dynamic *print-pretty*)
(xp.end-block ,var ,suffix)
(xp.write-prefix-suffix ,suffix ,var))))))
))
(define (xp.check-abbreviation xp object)
(cond ((and (dynamic *print-level*)
(>= (dynamic *xp.current-level*)
(dynamic *print-level*)))
(xp.write-char++ #\# XP)
(setf (dynamic *xp.abbreviation-happened*) '#t)
'#t)
((and (dynamic *xp.circularity-hash-table*)
(eq? (xp.circularity-process xp object '#f) 'subsequent))
'#t)
(else '#f)))
(define-syntax (pprint-pop)
`(xp.pprint-pop+ +l +x))
(define-syntax (xp.pprint-pop+ args xp)
`(if (xp.pprint-pop-check+ ,args ,xp)
(return-from logical-block '#f)
(if (null? ,args) '() (pop ,args))))
(define (xp.pprint-pop-check+ args xp)
(incf (dynamic *xp.current-length*))
(cond ((not (or (pair? args) (null? args)))
;; must be first to supersede length abbreviation
(xp.write-string++ ". " xp 0 2)
(xp.write+ args xp)
'#t)
((and (dynamic *print-length*)
(not (< *xp.current-length* (dynamic *print-length*))))
;; must supersede circularity check
(xp.write-string++ "..." xp 0 3)
(setf (dynamic *xp.abbreviation-happened*) '#t)
'#t)
((and (dynamic *xp.circularity-hash-table*)
(not (zero? *xp.current-length*)))
(case (xp.circularity-process xp args '#t)
((first)
(xp.write+ (cons (car args) (cdr args)) xp) '#t)
((subsequent)
'#t)
(else
'#f)))
(else
'#f)))
(define-syntax (pprint-exit-if-list-exhausted)
`(xp.pprint-exit-if-list-exhausted+ +l))
(define-syntax (xp.pprint-exit-if-list-exhausted+ mylist)
`(if (null? ,mylist) (return-from logical-block '#f)))
(define (pprint-newline kind . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(when (not (memq kind '(linear miser fill mandatory)))
(error "Invalid KIND argument ~A to PPRINT-NEWLINE" kind))
(when (and (xp.xp-structure-p stream) (dynamic *print-pretty*))
(xp.pprint-newline+ kind stream))
'#f))
(define (pprint-indent relative-to n . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(when (not (memq relative-to '(block current)))
(error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to))
(when (and (xp.xp-structure-p stream) (dynamic *print-pretty*))
(xp.pprint-indent+ relative-to n stream))
'#f))
(define (pprint-tab kind colnum colinc . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(when (not (memq kind '(line section line-relative section-relative)))
(error "Invalid KIND argument ~A to PPRINT-TAB" kind))
(when (and (xp.xp-structure-p stream) (dynamic *print-pretty*))
(xp.pprint-tab+ kind colnum colinc stream))
'#f))
;;;=====================================================================
;;; Standard print dispatch function
;;;=====================================================================
(define (xp.print-null object xp)
(declare (ignore object))
(xp.write-string+ "()" xp 0 2))
(define (xp.print-true object xp)
(declare (ignore object))
(xp.write-string+ "#t" xp 0 2))
(define (xp.print-false object xp)
(declare (ignore object))
(xp.write-string+ "#f" xp 0 2))
(define (xp.print-symbol object xp)
(if (dynamic *print-escape*)
(xp.print-default object xp)
(let ((mystring (symbol->string object)))
(xp.write-string+ mystring xp 0 (string-length mystring)))))
(define (xp.print-number object xp)
(if (and (integer? object)
(eqv? (dynamic *print-base*) 10)
(not (dynamic *print-radix*)))
(begin
(when (negative? object)
(xp.write-char++ #\- xp)
(setf object (- object)))
(xp.print-integer object xp))
(xp.print-default object xp)))
(define (xp.print-integer n xp)
(let ((quot (quotient n 10))
(rem (remainder n 10)))
(unless (zero? quot)
(xp.print-integer quot xp))
(xp.write-char++ (string-ref "0123456789" rem) xp)))
(define (xp.print-string object xp)
(if (dynamic *print-escape*)
(begin
(xp.write-char++ #\" xp)
(do ((i 0 (1+ i))
(n (string-length object)))
((= i n))
(let ((c (string-ref object i)))
(if (or (char=? c #\") (char=? c #\\))
(xp.write-char++ #\\ xp))
(xp.write-char++ c xp)))
(xp.write-char++ #\" xp))
(xp.write-string+ object xp 0 (string-length object))))
(define (xp.print-character object xp)
(if (dynamic *print-escape*)
(let ((name (char-name object)))
(xp.write-char++ #\# xp)
(xp.write-char++ #\\ xp)
(if name
(xp.write-string++ name xp 0 (string-length name))
(xp.write-char++ object xp)))
(xp.write-char+ object xp)))
(define (xp.print-vector object xp)
(let* ((pretty? (dynamic *print-pretty*))
(end (vector-length object)))
(pprint-logical-block (xp '() "#(" ")")
(do ((i 0 (1+ i)))
((eqv? i end) '#f)
(when (not (eqv? i 0))
(xp.write-char++ #\space xp)
(if pretty?
(xp.pprint-newline+ 'fill xp)))
(pprint-pop)
(xp.write+ (vector-ref object i) xp)
))))
(define (xp.print-table object xp)
(let ((pretty? (dynamic *print-pretty*)))
(pprint-logical-block (xp '() "#<Table" ">")
(table-for-each
(lambda (key value)
(xp.write-char++ #\space xp)
(if pretty?
(xp.pprint-newline+ 'fill xp))
(pprint-pop)
(xp.write+ (cons key value) xp))
object))))
(define (xp.print-pair object xp)
(if (dynamic *print-pretty*)
(xp.pretty-print-list object xp)
(xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
(do ()
((null? object) '#f)
(xp.write+ (xp.pprint-pop+ object xp) xp)
(when (not (null? object)) (xp.write-char++ #\space xp))))))
(define (xp.print-struct object xp)
(if (dynamic *print-structure*)
(print-structure-default object xp)
(funcall (get-structure-printer (struct-type-descriptor object))
object xp)))
(define (get-structure-printer td)
(or (td-printer td)
(if (eq? (td-name td) 'struct)
(function print-structure-default)
(get-structure-printer (td-parent-type td)))))
(define (print-structure-default object xp)
(let* ((td (struct-type-descriptor object))
(slots (td-slots td))
(pretty? (dynamic *print-pretty*)))
(pprint-logical-block (xp '() "#<Struct " ">")
(prin1 (td-name td) xp)
(when (dynamic *print-structure-slots*)
(dolist (s slots)
(write-char #\space xp)
(if pretty? (pprint-newline 'fill xp))
(pprint-pop)
(prin1 (sd-name s) xp)
(write-char #\space xp)
(write (funcall (sd-getter-function s) object) xp)))
)))
;;; This table can't be initialized until after all the functions
;;; have been defined.
(define *standard-print-dispatch-table*
(list (cons (function null?) (function xp.print-null))
(cons (lambda (x) (eq? x '#t)) (function xp.print-true))
(cons (function not) (function xp.print-false))
(cons (function symbol?) (function xp.print-symbol))
(cons (function number?) (function xp.print-number))
(cons (function pair?) (function xp.print-pair))
(cons (function string?) (function xp.print-string))
(cons (function char?) (function xp.print-character))
(cons (function struct?) (function xp.print-struct))
(cons (function vector?) (function xp.print-vector))
(cons (function table?) (function xp.print-table))))
(define (standard-print-dispatch object)
(standard-print-dispatch-aux
object (dynamic *standard-print-dispatch-table*)))
(define (standard-print-dispatch-aux object table)
(cond ((null? table) (function xp.print-default))
((funcall (car (car table)) object)
(cdr (car table)))
(else
(standard-print-dispatch-aux object (cdr table)))))
(setf (dynamic *print-dispatch*) (function standard-print-dispatch))
;;;=====================================================================
;;; Pretty printing formats for code
;;;=====================================================================
;;; The standard prettyprinters for lists dispatch off the CAR of the list.
(define *xp.pair-dispatch-table* (make-table))
(define (xp.pretty-print-list object xp)
(funcall (or (table-entry (dynamic *xp.pair-dispatch-table*) (car object))
(if (symbol? (car object)) (function xp.fn-call) '#f)
(lambda (object xp)
(pprint-fill xp object)))
object
xp))
;;; Must use pprint-logical-block (no +) in the following three, because they
;;; are exported functions.
;;; *** Note that the argument order on these is backwards; that's the
;;; *** way it is in Common Lisp....
(define (pprint-linear s object . moreargs)
(let* ((colon? (if (not (null? moreargs)) (pop moreargs) '#t))
(atsign? (if (not (null? moreargs)) (pop moreargs) '#f)))
(declare (ignore atsign?))
(pprint-logical-block (s object (if colon? "(" "") (if colon? ")" ""))
(pprint-exit-if-list-exhausted)
(do () ('#f)
(xp.write+ (pprint-pop) s)
(pprint-exit-if-list-exhausted)
(xp.write-char++ #\space s)
(xp.pprint-newline+ 'linear s)))))
(define (pprint-fill s object . moreargs)
(let* ((colon? (if (not (null? moreargs)) (pop moreargs) '#t))
(atsign? (if (not (null? moreargs)) (pop moreargs) '#f)))
(declare (ignore atsign?))
(pprint-logical-block (s object (if colon? "(" "") (if colon? ")" ""))
(pprint-exit-if-list-exhausted)
(do () ('#f)
(xp.write+ (pprint-pop) s)
(pprint-exit-if-list-exhausted)
(xp.write-char++ #\space s)
(xp.pprint-newline+ 'fill s)))))
(define (pprint-tabular s object . moreargs)
(let* ((colon? (if (not (null? moreargs)) (pop moreargs) '#t))
(atsign? (if (not (null? moreargs)) (pop moreargs) '#f))
(tabsize (or (and (not (null? moreargs)) (pop moreargs)) 16)))
(declare (ignore atsign?))
(pprint-logical-block (s object (if colon? "(" "") (if colon? ")" ""))
(pprint-exit-if-list-exhausted)
(do () ('#f)
(xp.write+ (pprint-pop) s)
(pprint-exit-if-list-exhausted)
(xp.write-char++ #\space s)
(xp.pprint-tab+ 'section-relative 0 tabsize s)
(xp.pprint-newline+ 'fill s)))))
(define (xp.fn-call object xp)
;; (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>")
(xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
(xp.write+ (xp.pprint-pop+ object xp) xp)
(xp.pprint-exit-if-list-exhausted+ object)
(xp.write-char++ #\space xp)
(xp.pprint-indent+ 'current 0 xp)
(xp.pprint-newline+ 'miser xp)
(xp.write+ (xp.pprint-pop+ object xp) xp)
(do ()
((null? object) '#f)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'linear xp)
(xp.write+ (xp.pprint-pop+ object xp) xp))))
;;; Although idiosyncratic, I have found this very useful to avoid large
;;; indentations when printing out code.
(define (xp.alternative-fn-call object xp)
(if (> (string-length (symbol->string (car object))) 12)
;; (formatter "~:<~1I~@{~W~^ ~_~}~:>")
(xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
(xp.pprint-indent+ 'block 1 xp)
(when (not (null? object))
(xp.write+ (xp.pprint-pop+ object xp) xp)
(do ()
((null? object) '#f)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'linear xp)
(xp.write+ (xp.pprint-pop+ object xp) xp))))
(xp.fn-call object xp)))
(define (xp.bind-list object xp . args)
(declare (ignore args))
;; (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>")
(xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
(when (not (null? object))
(pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f)
(do ()
((null? object) '#f)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'linear xp)
(pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f)))))
(define (xp.fbind-list object xp . args)
(declare (ignore args))
;; (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>")
(xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
(when (not (null? object))
(pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f)
(do ()
((null? object) '#f)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'linear xp)
(xp.block-like (xp.pprint-pop+ object xp) xp)))))
(define (xp.block-like object xp . args)
(declare (ignore args))
;; (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>")
(xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
(xp.pprint-indent+ 'block 1 xp)
(xp.pprint-exit-if-list-exhausted+ object)
(xp.write+ (xp.pprint-pop+ object xp) xp)
(xp.pprint-exit-if-list-exhausted+ object)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'miser xp)
(xp.write+ (xp.pprint-pop+ object xp) xp)
(xp.pprint-exit-if-list-exhausted+ object)
(do ()
((null? object) '#f)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'linear xp)
(xp.write+ (xp.pprint-pop+ object xp) xp))))
(define (xp.print-fancy-fn-call object xp template)
(xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
(xp.write+ (xp.pprint-pop+ object xp) xp)
(xp.pprint-indent+ 'current 1 xp)
(do ((i 0 (1+ i))
(in-first-section '#t))
((null? object) '#f)
(xp.write-char++ #\space xp)
(when (eqv? i (car template))
(xp.pprint-indent+ 'block (cadr template) xp)
(setf template (cddr template))
(setf in-first-section '#f))
(pprint-newline (cond ((zero? i) 'miser)
(in-first-section 'fill)
(else 'linear))
xp)
(xp.write+ (xp.pprint-pop+ object xp) xp))))
(define (xp.let-print object xp)
;; (formatter "~:<~1I~W~^ ~@_~/xp:xp.bind-list/~^~@{ ~_~W~^~}~:>")
(xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
(xp.pprint-indent+ 'block 1 xp)
(xp.write+ (xp.pprint-pop+ object xp) xp)
(xp.pprint-exit-if-list-exhausted+ object)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'miser xp)
(xp.bind-list (xp.pprint-pop+ object xp) xp '#f '#f)
(xp.pprint-exit-if-list-exhausted+ object)
(do ()
((null? object) '#f)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'linear xp)
(xp.write+ (xp.pprint-pop+ object xp) xp))))
(define (xp.flet-print object xp)
(xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
(xp.pprint-indent+ 'block 1 xp)
(xp.write+ (xp.pprint-pop+ object xp) xp)
(xp.pprint-exit-if-list-exhausted+ object)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'miser xp)
(xp.fbind-list (xp.pprint-pop+ object xp) xp '#f '#f)
(xp.pprint-exit-if-list-exhausted+ object)
(do ()
((null? object) '#f)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'linear xp)
(xp.write+ (xp.pprint-pop+ object xp) xp))))
(define (xp.cond-print object xp)
;; (formatter "~:<~W~^ ~:I~@_~@{~:/xp:pprint-linear/~^ ~_~}~:>")
(xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
(xp.write+ (xp.pprint-pop+ object xp) xp)
(xp.pprint-exit-if-list-exhausted+ object)
(xp.write-char++ #\space xp)
(xp.pprint-indent+ 'current 0 xp)
(xp.pprint-newline+ 'miser xp)
(pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f)
(do ()
((null? object) '#f)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'linear xp)
(pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f))))
(define (xp.do-print object xp)
;; (formatter "~:<~W~^ ~:I~@_~/xp:xp.bind-list/~^ ~_~:/xp:pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>")
(xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
(xp.write+ (xp.pprint-pop+ object xp) xp)
(xp.pprint-exit-if-list-exhausted+ object)
(xp.write-char++ #\space xp)
(xp.pprint-indent+ 'current 0 xp)
(xp.pprint-newline+ 'miser xp)
(xp.bind-list (xp.pprint-pop+ object xp) xp '#f '#f)
(xp.pprint-exit-if-list-exhausted+ object)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'linear xp)
(pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f)
(xp.write-char++ #\space xp)
(xp.pprint-indent+ 'block 1 xp)
(do ()
((null? object) '#f)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'linear xp)
(xp.write+ (xp.pprint-pop+ object xp) xp))))
(define (xp.mvb-print object xp)
(xp.print-fancy-fn-call object xp '(1 3 2 1)))
(define (xp.setf-print object xp)
;; (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>")
(xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
(xp.write+ (xp.pprint-pop+ object xp) xp)
(xp.pprint-exit-if-list-exhausted+ object)
(xp.write-char++ #\space xp)
(xp.pprint-indent+ 'current 0 xp)
(xp.pprint-newline+ 'miser xp)
(xp.write+ (xp.pprint-pop+ object xp) xp)
(do ()
((null? object) '#f)
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'fill xp)
(xp.write+ (xp.pprint-pop+ object xp) xp)
(when (not (null? object))
(xp.write-char++ #\space xp)
(xp.pprint-newline+ 'linear xp)
(xp.write+ (xp.pprint-pop+ object xp) xp)))))
(define (xp.quote-print object xp)
(if (and (pair? (cdr object)) (null? (cddr object)))
(begin
(xp.write-char++ #\' xp)
(xp.write+ (cadr object) xp))
(pprint-fill xp object)))
(define (xp.up-print object xp)
(xp.print-fancy-fn-call object xp '(0 3 1 1)))
;;; Install printers for built-in macros and special forms into the
;;; standard dispatch table.
(define-local-syntax (define-printer symbol function)
`(setf (table-entry (dynamic *xp.pair-dispatch-table*) ',symbol)
(function ,function)))
;;; *** Missing support for backquote here.
(define-printer quote xp.quote-print)
(define-printer lambda xp.block-like)
(define-printer when xp.block-like)
(define-printer unless xp.block-like)
(define-printer cond xp.cond-print)
(define-printer case xp.block-like)
(define-printer setf xp.setf-print)
(define-printer set! xp.setf-print)
(define-printer let xp.let-print)
(define-printer let* xp.let-print)
(define-printer letrec xp.let-print)
(define-printer flet xp.flet-print)
(define-printer labels xp.flet-print)
(define-printer dynamic-let xp.let-print)
(define-printer block xp.block-like)
(define-printer do xp.do-print)
(define-printer dolist xp.block-like)
(define-printer dotimes xp.block-like)
(define-printer multiple-value-bind xp.mvb-print)
(define-printer let/cc xp.block-like)
(define-printer unwind-protect xp.up-print)
(define-printer define xp.block-like)
(define-printer define-syntax xp.block-like)
(define-printer define-local-syntax xp.block-like)
(define-printer pprint-logical-block xp.block-like)
(define-printer xp.pprint-logical-block+ xp.block-like)
;;; Here are some hacks for struct macros.
(define-printer update-slots xp.mvb-print)
(define-printer make xp.block-like)
|