summaryrefslogtreecommitdiff
path: root/support/pprint.scm
diff options
context:
space:
mode:
Diffstat (limited to 'support/pprint.scm')
-rw-r--r--support/pprint.scm1788
1 files changed, 1788 insertions, 0 deletions
diff --git a/support/pprint.scm b/support/pprint.scm
new file mode 100644
index 0000000..9b28ec8
--- /dev/null
+++ b/support/pprint.scm
@@ -0,0 +1,1788 @@
+;;; 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 "~&section-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)
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-16 19:15:08 +0000