home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / support / pprint.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  63.1 KB  |  1,792 lines  |  [TEXT/CCL2]
  1. ;;; pprint.scm -- xp pretty-printer in Scheme
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  29 Oct 1991
  5. ;;;
  6. ;;;
  7. ;;; This code is adapted from the XP pretty printer originally written
  8. ;;; in Common Lisp by Dick Waters.  Here is the copyright notice attached
  9. ;;; to the original XP source file:
  10. ;;;
  11. ;;;------------------------------------------------------------------------
  12. ;;;
  13. ;;; Copyright 1989,1990 by the Massachusetts Institute of Technology,
  14. ;;; Cambridge, Massachusetts.
  15. ;;; 
  16. ;;; Permission to use, copy, modify, and distribute this software and its
  17. ;;; documentation for any purpose and without fee is hereby granted,
  18. ;;; provided that this copyright and permission notice appear in all
  19. ;;; copies and supporting documentation, and that the name of M.I.T. not
  20. ;;; be used in advertising or publicity pertaining to distribution of the
  21. ;;; software without specific, written prior permission. M.I.T. makes no
  22. ;;; representations about the suitability of this software for any
  23. ;;; purpose.  It is provided "as is" without express or implied warranty.
  24. ;;; 
  25. ;;;  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
  26. ;;;  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
  27. ;;;  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
  28. ;;;  ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
  29. ;;;  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
  30. ;;;  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  31. ;;;  SOFTWARE.
  32. ;;;
  33. ;;;------------------------------------------------------------------------
  34. ;;;
  35.  
  36.  
  37. ;;;=====================================================================
  38. ;;; Variables
  39. ;;;=====================================================================
  40.  
  41.  
  42. ;;; External variables.  These may be specially bound by user code.
  43.  
  44. (define *print-escape*           '#t)
  45. (define *print-circle*           '#f)
  46. (define *print-level*            '#f)
  47. (define *print-length*           '#f)
  48. (define *print-base*             10)
  49. (define *print-radix*            '#f)
  50.  
  51.  
  52. (define *print-shared*           '#f)
  53. (define *print-pretty*           '#f)
  54. (define *print-right-margin*     '#f)
  55. (define *print-miser-width*      40)
  56. (define *print-lines*            '#f)
  57. (define *default-right-margin*   70)
  58. (define *last-abbreviated-printing*
  59.   (lambda maybe-stream
  60.     (declare (ignore maybe-stream))
  61.     '#f))
  62.  
  63. (define *print-dispatch*         '#f)  ; initialized later
  64. (define *print-structure*        '#f)
  65. (define *print-structure-slots*  '#t)
  66.  
  67.  
  68. ;;; *** These variables aren't really supported, but they should be.
  69.  
  70. (define *print-readably*         '#f)
  71. (define *print-case*             'upcase)
  72.  
  73.  
  74.  
  75. ;;; Internal variables.  These are all specially rebound when we initiate
  76. ;;; printing to an XP stream.
  77.  
  78. (define *xp.current-level* 0)
  79. (define *xp.current-length* 0)
  80. (define *xp.abbreviation-happened* '#f)
  81. (define *xp.locating-circularities* '#f)
  82. (define *xp.parents* '())
  83. (define *xp.circularity-hash-table* '#f)
  84. (define *xp.line-limit-abbreviation-exit*
  85.   (lambda values
  86.     (declare (ignore values))
  87.     (error "No line limit abbreviation exit in this extent.")))
  88.  
  89.  
  90.  
  91. ;;;=====================================================================
  92. ;;; Dispatching
  93. ;;;=====================================================================
  94.  
  95. ;;; Since Scheme doesn't have type specifiers or named structures,
  96. ;;; the dispatch mechanism defined for the Common Lisp XP won't work
  97. ;;; very well.  A more general alternative might be to maintain a
  98. ;;; sorted list of <priority predicate printer> tuples, but having to
  99. ;;; try each of these in sequence could get very slow.
  100. ;;;
  101. ;;; What I've decided to to instead is to have the value of
  102. ;;; *print-dispatch* be a user-defined dispatcher
  103. ;;; function:  given an object, it should return a function to print it,
  104. ;;; or #f.  In the latter case, the object is printed in some default
  105. ;;; way.
  106. ;;;
  107. ;;; The standard dispatcher function is defined towards the bottom
  108. ;;; of this file.  If you are writing your own dispatcher, you should
  109. ;;; probably call this function as the fall-through case.
  110.  
  111. (define (xp.get-printer object)
  112.   (funcall (dynamic *print-dispatch*) object))
  113.  
  114.  
  115. ;;;=====================================================================
  116. ;;; Internal data structures
  117. ;;;=====================================================================
  118.  
  119. (define-integrable xp.block-stack-entry-size 1)
  120. (define-integrable xp.prefix-stack-entry-size 5)
  121. (define-integrable xp.queue-entry-size 7)
  122. (define-integrable xp.buffer-entry-size 1)
  123. (define-integrable xp.prefix-entry-size 1)
  124. (define-integrable xp.suffix-entry-size 1)
  125.  
  126. (define-integrable xp.block-stack-min-size (* 35 xp.block-stack-entry-size))
  127. (define-integrable xp.prefix-stack-min-size (* 30 xp.prefix-stack-entry-size))
  128. (define-integrable xp.queue-min-size (* 75 xp.queue-entry-size))
  129. (define-integrable xp.buffer-min-size 256)
  130. (define-integrable xp.prefix-min-size 256)
  131. (define-integrable xp.suffix-min-size 256)
  132.  
  133.  
  134. ;;; The xp stream structure.
  135. ;;; Fields without defaults are initialized by xp.initialize-xp, below.
  136.  
  137. (define-struct xp
  138.   (prefix xp.)
  139.   (predicate xp.xp-structure-p)
  140.   (slots
  141.    (base-stream (type t) (default '#f))
  142.    (linel (type fixnum) (default 0))
  143.    (line-limit (type (maybe fixnum)) (default '#f))
  144.    (line-no (type fixnum) (default 0))
  145.    (char-mode (type (enum #f up down cap0 cap1 capw)) (default '#f))
  146.    (char-mode-counter (type fixnum) (default 0))
  147.    ;; number of logical blocks at qright that are started but not ended.
  148.    (depth-in-blocks (type fixnum) (default 0))
  149.    ;; This stack is pushed and popped in accordance with the way blocks
  150.    ;; are nested at the moment they are entered into the queue.
  151.    (block-stack (type vector) (default (make-vector xp.block-stack-min-size)))
  152.    ;; Pointer into block-stack vector.
  153.    (block-stack-ptr (type fixnum) (default 0))
  154.    ;; This is a string that builds up the line images that will be printed out.
  155.    (buffer (type string) (default (make-string xp.buffer-min-size)))
  156.    ;; The output character position of the first character in the buffer;
  157.    ;; nonzero only if a partial line has been output.
  158.    (charpos (type fixnum) (default 0))
  159.    ;; The index in the buffer where the next character is to be inserted.
  160.    (buffer-ptr (type fixnum) (default 0))
  161.    ;; This is used in computing total lengths.  It is changed to reflect
  162.    ;; all shifting and insertion of prefixes so that total length computes
  163.    ;; things as they would be if they were all on one line.
  164.    (buffer-offset (type fixnum) (default 0))
  165.    ;; The queue of action descriptors.  The value is a vector.
  166.    (queue (type vector) (default (make-vector xp.queue-min-size)))
  167.    ;; Index of next queue entry to dequeue.
  168.    (qleft (type fixnum) (default 0))
  169.    ;; Index of last entry queued; queue is empty when (> qleft qright).
  170.    (qright (type fixnum) (default 0))
  171.    ;; This stores the prefix that should be used at the start of the line.
  172.    (prefix (type string) (default (make-string xp.buffer-min-size)))
  173.    ;; This stack is pushed and popped in accordance with the way blocks
  174.    ;; are nested at the moment things are taken off the queue and printed.
  175.    (prefix-stack (type vector) (default (make-vector xp.prefix-stack-min-size)))
  176.    ;; Index into prefix-stack.
  177.    (prefix-stack-ptr (type fixnum) (default 0))
  178.    ;; This stores the suffixes that have to be pritned to close of the
  179.    ;; current open blocks.  For convenience in popping, the whole suffix
  180.    ;; is stored in reverse order.
  181.    (suffix (type string) (default (make-string xp.buffer-min-size)))
  182.    ))
  183.  
  184.  
  185. (define (xp.make-xp-structure)
  186.   (make xp))
  187.  
  188.  
  189. ;;; Positions within the buffer are kept in three ways:
  190. ;;; * Buffer position (eg BUFFER-PTR)
  191. ;;; * Line position (eg (+ BUFFER-PTR CHARPOS)).
  192. ;;;   Indentations are stored in this form.
  193. ;;; * Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET))
  194. ;;;   Positions are stored in this form.
  195.  
  196. (define-local-syntax (xp.lp<-bp xp . maybe-ptr)
  197.   (let ((ptr  (if (not (null? maybe-ptr))
  198.           (car maybe-ptr)
  199.           `(xp.buffer-ptr ,xp))))
  200.     `(+ ,ptr (xp.charpos ,xp))))
  201.  
  202. (define-local-syntax (xp.tp<-bp xp)
  203.   `(+ (xp.buffer-ptr ,xp) (xp.buffer-offset ,xp)))
  204.  
  205. (define-local-syntax (xp.bp<-lp xp ptr)
  206.   `(- ,ptr (xp.charpos ,xp)))
  207.  
  208. (define-local-syntax (xp.bp<-tp xp ptr)
  209.   `(- ,ptr (xp.buffer-offset ,xp)))
  210.  
  211. (define-local-syntax (xp.lp<-tp xp ptr)
  212.   `(xp.lp<-bp ,xp (xp.bp<-tp ,xp ,ptr)))
  213.  
  214.  
  215. ;;; Define some macros for growing the various stacks in the xp-structure.
  216.  
  217. (define-local-syntax (xp.check-block-stack-size xp ptr)
  218.   `(setf (xp.block-stack ,xp)
  219.      (xp.grow-vector (xp.block-stack ,xp) ,ptr xp.block-stack-entry-size)))
  220.  
  221. (define-local-syntax (xp.check-prefix-size xp ptr)
  222.   `(setf (xp.prefix ,xp)
  223.      (xp.grow-string (xp.prefix ,xp) ,ptr xp.prefix-entry-size)))
  224.  
  225. (define-local-syntax (xp.check-prefix-stack-size xp ptr)
  226.   `(setf (xp.prefix-stack ,xp)
  227.      (xp.grow-vector (xp.prefix-stack ,xp) ,ptr xp.prefix-stack-entry-size)))
  228.  
  229. (define-local-syntax (xp.check-queue-size xp ptr)
  230.   `(setf (xp.queue ,xp)
  231.      (xp.grow-vector (xp.queue ,xp) ,ptr xp.queue-entry-size)))
  232.  
  233. (define-local-syntax (xp.check-buffer-size xp ptr)
  234.   `(setf (xp.buffer ,xp)
  235.      (xp.grow-string (xp.buffer ,xp) ,ptr xp.buffer-entry-size)))
  236.  
  237. (define-local-syntax (xp.check-suffix-size xp ptr)
  238.   `(setf (xp.suffix ,xp)
  239.      (xp.grow-string (xp.suffix ,xp) ,ptr xp.suffix-entry-size)))
  240.  
  241. (define (xp.grow-vector old ptr entry-size)
  242.   (let ((end  (vector-length old)))
  243.     (if (> ptr (- end entry-size))
  244.     (let ((new  (make-vector (+ ptr 50))))
  245.       (dotimes (i end)
  246.         (setf (vector-ref new i) (vector-ref old i)))
  247.       new)
  248.     old)))
  249.  
  250. (define (xp.grow-string old ptr entry-size)
  251.   (let ((end  (string-length old)))
  252.     (if (> ptr (- end entry-size))
  253.     (let ((new  (make-string (+ ptr 50))))
  254.       (dotimes (i end)
  255.         (setf (string-ref new i) (string-ref old i)))
  256.       new)
  257.     old)))
  258.  
  259.  
  260.  
  261. ;;; Things for manipulating the block stack.
  262.  
  263. (define-local-syntax (xp.section-start xp)
  264.   `(vector-ref (xp.block-stack ,xp) (xp.block-stack-ptr ,xp)))
  265.  
  266. (define (xp.push-block-stack xp)
  267.   (incf (xp.block-stack-ptr xp) xp.block-stack-entry-size)
  268.   (xp.check-block-stack-size xp (xp.block-stack-ptr xp)))
  269.  
  270. (define (xp.pop-block-stack xp)
  271.   (decf (xp.block-stack-ptr xp) xp.block-stack-entry-size))
  272.  
  273.  
  274. ;;; Prefix stack manipulations
  275.  
  276. (define-local-syntax (xp.prefix-ptr xp)
  277.   `(vector-ref (xp.prefix-stack ,xp) (xp.prefix-stack-ptr ,xp)))
  278. (define-local-syntax (xp.suffix-ptr xp)
  279.   `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 1)))
  280. (define-local-syntax (non-blank-prefix-ptr xp)
  281.   `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 2)))
  282. (define-local-syntax (initial-prefix-ptr xp)
  283.   `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 3)))
  284. (define-local-syntax (xp.section-start-line xp)
  285.   `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 4)))
  286.  
  287. (define (xp.push-prefix-stack xp)
  288.   (let ((old-prefix 0)
  289.     (old-suffix 0)
  290.     (old-non-blank 0))
  291.     (when (not (negative? (xp.prefix-stack-ptr xp)))
  292.       (setf old-prefix (xp.prefix-ptr xp))
  293.       (setf old-suffix (xp.suffix-ptr xp))
  294.       (setf  old-non-blank (non-blank-prefix-ptr xp)))
  295.     (incf (xp.prefix-stack-ptr xp) xp.prefix-stack-entry-size)
  296.     (xp.check-prefix-stack-size xp (xp.prefix-stack-ptr xp))
  297.     (setf (xp.prefix-ptr xp) old-prefix)
  298.     (setf (xp.suffix-ptr xp) old-suffix)
  299.     (setf (non-blank-prefix-ptr xp) old-non-blank)))
  300.  
  301. (define (xp.pop-prefix-stack xp)
  302.   (decf (xp.prefix-stack-ptr xp) xp.prefix-stack-entry-size))
  303.  
  304.  
  305. ;;; The queue entries have several parts:
  306. ;;; QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK
  307. ;;; QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH
  308. ;;;  or :BLOCK/:CURRENT
  309. ;;; QPOS total position corresponding to this entry
  310. ;;; QDEPTH depth in blocks of this entry.
  311. ;;; QEND offset to entry marking end of section this entry starts.
  312. ;;   (NIL until known.)
  313. ;;;  Only :start-block and non-literal :newline entries can start sections.
  314. ;;; QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known).
  315. ;;; QARG for :IND indentation delta
  316. ;;;      for :START-BLOCK suffix in the block if any.
  317. ;;;                       or if per-line-prefix then cons of suffix and
  318. ;;;                       per-line-prefix.
  319. ;;;      for :END-BLOCK suffix for the block if any.
  320.  
  321. (define-local-syntax (xp.qtype   xp index)
  322.   `(vector-ref (xp.queue ,xp) ,index))
  323. (define-local-syntax (xp.qkind   xp index)
  324.   `(vector-ref (xp.queue ,xp) (1+ ,index)))
  325. (define-local-syntax (xp.qpos    xp index)
  326.   `(vector-ref (xp.queue ,xp) (+ ,index 2)))
  327. (define-local-syntax (xp.qdepth  xp index)
  328.   `(vector-ref (xp.queue ,xp) (+ ,index 3)))
  329. (define-local-syntax (xp.qend    xp index)
  330.   `(vector-ref (xp.queue ,xp) (+ ,index 4)))
  331. (define-local-syntax (xp.qoffset xp index)
  332.   `(vector-ref (xp.queue ,xp) (+ ,index 5)))
  333. (define-local-syntax (xp.qarg    xp index)
  334.   `(vector-ref (xp.queue ,xp) (+ ,index 6)))
  335.  
  336. ;;; we shift the queue over rather than using a circular queue because
  337. ;;; that works out to be a lot faster in practice.  Note, short printout
  338. ;;; does not ever cause a shift, and even in long printout, the queue is
  339. ;;; shifted left for free every time it happens to empty out.
  340.  
  341. (define (xp.enqueue xp type kind . maybe-arg)
  342.   (incf (xp.qright xp) xp.queue-entry-size)
  343.   (when (> (xp.qright xp) (- xp.queue-min-size xp.queue-entry-size))
  344.     (vector-replace (xp.queue xp) (xp.queue xp) 0 (xp.qleft xp) (xp.qright xp))
  345.     (setf (xp.qright xp) (- (xp.qright xp) (xp.qleft xp)))
  346.     (setf (xp.qleft xp) 0))
  347.   (xp.check-queue-size xp (xp.qright xp))
  348.   (setf (xp.qtype xp (xp.qright xp)) type)
  349.   (setf (xp.qkind xp (xp.qright xp)) kind)
  350.   (setf (xp.qpos xp (xp.qright xp)) (xp.tp<-bp xp))
  351.   (setf (xp.qdepth xp (xp.qright xp)) (xp.depth-in-blocks xp))
  352.   (setf (xp.qend xp (xp.qright xp)) '#f)
  353.   (setf (xp.qoffset xp (xp.qright xp)) '#f)
  354.   (setf (xp.qarg xp (xp.qright xp)) (car maybe-arg)))
  355.  
  356. (define-local-syntax (xp.qnext index) `(+ ,index xp.queue-entry-size))
  357.  
  358.  
  359.  
  360. ;;; Print routine for xp structures
  361. ;;; *** this is broken, it uses unimplemented format options.
  362.  
  363. (define *xp.describe-xp-streams-fully* '#f)
  364.  
  365. (define (xp.describe-xp xp . maybe-stream)
  366.   (let ((s  (if (not (null? maybe-stream))
  367.         (car maybe-stream)
  368.         (current-output-port))))
  369.     (format s "#<XP stream ")
  370.     (if (not (xp.base-stream xp))
  371.     (format s "not currently in use")
  372.     (begin
  373.        (format s "outputting to ~S" (xp.base-stream xp))
  374.       (format s "~&buffer= ~S"
  375.           (substring (xp.buffer xp) 0 (max (xp.buffer-ptr xp) 0)))
  376.       (if (not (dynamic *xp.describe-xp-streams-fully*))
  377.           (format s " ...")
  378.           (begin
  379.             (format s "~&   pos   _123456789_123456789_123456789_123456789")
  380.         (format s "~&depth-in-blocks= ~D linel= ~D line-no= ~D line-limit= ~D"
  381.             (xp.depth-in-blocks xp) (xp.linel xp)
  382.             (xp.line-no xp) (xp.line-limit xp))
  383.         (when (or (xp.char-mode xp) (not (zero? (xp.char-mode-counter xp))))
  384.           (format s "~&char-mode= ~S char-mode-counter= ~D"
  385.               (xp.char-mode xp) (xp.char-mode-counter xp)))
  386.         (unless (negative? (xp.block-stack-ptr xp))
  387.           (format s "~§ion-start")
  388.           (do ((save (xp.block-stack-ptr xp)))
  389.               ((negative? (xp.block-stack-ptr xp))
  390.                (setf (xp.block-stack-ptr xp) save))
  391.               (format s " ~D" (xp.section-start xp))
  392.               (xp.pop-block-stack xp)))
  393.         (format s "~&linel= ~D charpos= ~D buffer-ptr= ~D buffer-offset= ~D"
  394.             (xp.linel xp) (xp.charpos xp)
  395.             (xp.buffer-ptr xp) (xp.buffer-offset xp))
  396.         (unless (negative? (xp.prefix-stack-ptr xp))
  397.           (format s "~&prefix= ~S"
  398.               (substring (xp.prefix xp) 0 (max (xp.prefix-ptr xp) 0)))
  399.           (format s "~&suffix= ~S"
  400.               (substring (xp.suffix xp) 0 (max (xp.suffix-ptr xp) 0))))
  401.         (unless (> (xp.qleft xp) (xp.qright xp))
  402.           (format s "~&ptr type         kind           pos depth end offset arg")
  403.           (do ((p (xp.qleft xp) (xp.qnext p)))
  404.               ((> p (xp.qright xp)))
  405.               (format s "~&~4A~13A~15A~4A~6A~4A~7A~A"
  406.                   (/ (- p (xp.qleft xp)) xp.queue-entry-size)
  407.                   (xp.qtype xp p)
  408.                   (if (memq (xp.qtype xp p) '(newline ind))
  409.                   (xp.qkind xp p)
  410.                   "")
  411.                   (xp.bp<-tp xp (xp.qpos xp p))
  412.                   (xp.qdepth xp p)
  413.                   (if (not (memq (xp.qtype xp p)
  414.                          '(newline start-block)))
  415.                   ""
  416.                   (and (xp.qend xp p)
  417.                        (/ (- (+ p (xp.qend xp p)) (xp.qleft xp))
  418.                       xp.queue-entry-size)))
  419.                   (if (not (eq? (xp.qtype xp p) 'start-block))
  420.                   ""
  421.                   (and (xp.qoffset xp p)
  422.                        (/ (- (+ p (xp.qoffset xp p)) (xp.qleft xp))
  423.                       xp.queue-entry-size)))
  424.                   (if (not (memq (xp.qtype xp p)
  425.                          '(ind start-block end-block)))
  426.                   ""
  427.                   (xp.qarg xp p)))))
  428.         (unless (negative? (xp.prefix-stack-ptr xp))
  429.           (format s "~&initial-prefix-ptr prefix-ptr suffix-ptr non-blank start-line")
  430.           (do ((save (xp.prefix-stack-ptr xp)))
  431.               ((negative? (xp.prefix-stack-ptr xp))
  432.                (setf (xp.prefix-stack-ptr xp) save))
  433.               (format s "~& ~19A~11A~11A~10A~A"
  434.                   (initial-prefix-ptr xp)
  435.                   (xp.prefix-ptr xp)
  436.                   (xp.suffix-ptr xp)
  437.                   (non-blank-prefix-ptr xp)
  438.                   (xp.section-start-line xp))
  439.               (xp.pop-prefix-stack xp)))))))
  440.     (format s ">")))
  441.  
  442.  
  443.  
  444. ;;; Allocation of XP structures
  445.  
  446. ;;; This maintains a list of XP structures.  We save them
  447. ;;; so that we don't have to create new ones all of the time.
  448. ;;; We have separate objects so that many can be in use at once
  449. ;;; (e.g. for printing to multiple streams).
  450.  
  451. (define xp.free-xps '())
  452.  
  453. (define (xp.get-pretty-print-stream stream)
  454.   (xp.initialize-xp
  455.       (if (not (null? xp.free-xps))
  456.       (pop xp.free-xps)
  457.       (xp.make-xp-structure))
  458.       stream))
  459.  
  460.  
  461. ;;; If you call this, the xp-stream gets efficiently recycled.
  462.  
  463. (define (xp.free-pretty-print-stream xp)
  464.   (setf (xp.base-stream xp) '#f)
  465.   (if (not (memq xp xp.free-xps))
  466.       (push xp xp.free-xps)))
  467.  
  468.  
  469. ;;; This is called to initialize things when you start pretty printing.
  470.  
  471. (define (xp.initialize-xp xp stream)
  472.   (setf (xp.base-stream xp) stream)
  473.   (setf (xp.linel xp)
  474.     (max 0
  475.          (cond ((dynamic *print-right-margin*))
  476.            ((internal-output-width stream))
  477.            (else (dynamic *default-right-margin*)))))
  478.   (setf (xp.line-limit xp) (dynamic *print-lines*))
  479.   (setf (xp.line-no xp) 1)
  480.   (setf (xp.char-mode xp) '#f)
  481.   (setf (xp.char-mode-counter xp) 0)
  482.   (setf (xp.depth-in-blocks xp) 0)
  483.   (setf (xp.block-stack-ptr xp) 0)
  484.   (setf (xp.charpos xp) (or (internal-output-position stream) 0))
  485.   (setf (xp.section-start xp) 0)
  486.   (setf (xp.buffer-ptr xp) 0)
  487.   (setf (xp.buffer-offset xp) (xp.charpos xp))
  488.   (setf (xp.qleft xp) 0)
  489.   (setf (xp.qright xp) (- xp.queue-entry-size))
  490.   (setf (xp.prefix-stack-ptr xp) (- xp.prefix-stack-entry-size))
  491.   xp)
  492.  
  493.  
  494.  
  495. ;;; The char-mode stuff is a bit tricky.
  496. ;;; one can be in one of the following modes:
  497. ;;; NIL no changes to characters output.
  498. ;;; :UP CHAR-UPCASE used.
  499. ;;; :DOWN CHAR-DOWNCASE used.
  500. ;;; :CAP0 capitalize next alphanumeric letter then switch to :DOWN.
  501. ;;; :CAP1 capitalize next alphanumeric letter then switch to :CAPW
  502. ;;; :CAPW downcase letters.  When a word break letter found, switch to :CAP1.
  503. ;;; It is possible for ~(~) to be nested in a format string, but note that
  504. ;;; each mode specifies what should happen to every letter.  Therefore, inner
  505. ;;; nested modes never have any effect.  You can just ignore them.
  506.  
  507. (define (xp.push-char-mode xp new-mode)
  508.   (if (zero? (xp.char-mode-counter xp))
  509.       (setf (xp.char-mode xp) new-mode))
  510.   (incf (xp.char-mode-counter xp)))
  511.  
  512. (define (xp.pop-char-mode xp)
  513.   (decf (xp.char-mode-counter xp))
  514.   (if (zero? (xp.char-mode-counter xp))
  515.       (setf (xp.char-mode xp) '#f)))
  516.  
  517.  
  518. ;;; Assumes is only called when char-mode is non-nil
  519.  
  520. (define (xp.handle-char-mode xp char)
  521.   (case (xp.char-mode xp)
  522.     ((CAP0)
  523.      (cond ((not (or (char-alphabetic? char) (char-numeric? char))) char)
  524.        (else (setf (xp.char-mode xp) 'DOWN) (char-upcase char))))
  525.     ((CAP1)
  526.      (cond ((not (or (char-alphabetic? char) (char-numeric? char))) char)
  527.        (else (setf (xp.char-mode xp) 'CAPW) (char-upcase char))))
  528.     ((CAPW)
  529.      (cond ((or (char-alphabetic? char) (char-numeric? char))
  530.         (char-downcase char))
  531.        (else (setf (xp.char-mode xp) 'CAP1) char)))
  532.     ((UP)
  533.      (char-upcase char))
  534.     (else
  535.      (char-downcase char)))) ;DOWN
  536.  
  537.  
  538. ;;; All characters output are passed through the handler above.  However, 
  539. ;;; it must be noted that on-each-line prefixes are only processed in the 
  540. ;;; context of the first place they appear.  They stay the same later no 
  541. ;;; matter what.  Also non-literal newlines do not count as word breaks.
  542.  
  543. ;;; This handles the basic outputting of characters.  note + suffix means that
  544. ;;; the stream is known to be an XP stream, all inputs are mandatory, and no
  545. ;;; error checking has to be done.  Suffix ++ additionally means that the
  546. ;;; output is guaranteed not to contain a newline char.
  547.  
  548. (define (xp.write-char+ char xp)
  549.   (if (eqv? char #\newline)
  550.       (xp.pprint-newline+ 'unconditional xp)
  551.       (xp.write-char++ char xp)))
  552.  
  553. (define (xp.write-string+ mystring xp start end)
  554.   (let ((next-newline (string-position #\newline mystring start end)))
  555.     (if next-newline
  556.     (begin
  557.       (xp.write-string++ mystring xp start next-newline)
  558.       (xp.pprint-newline+ 'unconditional xp)
  559.       (xp.write-string+ mystring xp (1+ next-newline) end))
  560.     (xp.write-string++ mystring xp start end))))
  561.  
  562.  
  563. ;;; note this checks (> BUFFER-PTR LINEL) instead of (> (xp.lp<-bp) LINEL)
  564. ;;; this is important so that when things are longer than a line they
  565. ;;; end up getting printed in chunks of size LINEL.
  566.  
  567. (define (xp.write-char++ char xp)
  568.   (when (> (xp.buffer-ptr xp) (xp.linel xp))
  569.     (xp.force-some-output xp))
  570.   (let ((new-buffer-end (1+ (xp.buffer-ptr xp))))
  571.     (xp.check-buffer-size xp new-buffer-end)
  572.     (if (xp.char-mode xp) (setf char (xp.handle-char-mode xp char)))
  573.     (setf (string-ref (xp.buffer xp) (xp.buffer-ptr xp)) char)    
  574.     (setf (xp.buffer-ptr xp) new-buffer-end)))
  575.  
  576. (define (xp.force-some-output xp)
  577.   (xp.attempt-to-output xp '#f '#f)
  578.   (when (> (xp.buffer-ptr xp) (xp.linel xp)) ;only if printing off end of line
  579.     (xp.attempt-to-output xp '#t '#t)))
  580.  
  581. (define (xp.write-string++ mystring xp start end)
  582.   (when (> (xp.buffer-ptr xp) (xp.linel xp))
  583.     (xp.force-some-output xp))
  584.   (xp.write-string+++ mystring xp start end))
  585.  
  586.  
  587. ;;; never forces output; therefore safe to call from within xp.output-line.
  588.  
  589. (define (xp.write-string+++ mystring xp start end) 
  590.   (let ((new-buffer-end (+ (xp.buffer-ptr xp) (- end start))))
  591.     (xp.check-buffer-size xp new-buffer-end)
  592.     (do ((buffer (xp.buffer xp))
  593.      (i (xp.buffer-ptr xp) (1+ i))
  594.      (j start (1+ j)))
  595.     ((= j end))
  596.       (let ((char (string-ref mystring j)))
  597.     (if (xp.char-mode xp) (setf char (xp.handle-char-mode xp char)))
  598.     (setf (string-ref buffer i) char)))
  599.     (setf (xp.buffer-ptr xp) new-buffer-end)))
  600.  
  601.  
  602. (define (xp.pprint-tab+ kind colnum colinc xp)
  603.   (let ((indented? '#f)
  604.     (relative? '#f))
  605.     (case kind
  606.       ((section) (setf indented? '#t))
  607.       ((line-relative) (setf relative? '#t))
  608.       ((section-relative) (setf indented? '#t) (setf relative? '#t)))
  609.     (let* ((current
  610.          (if (not indented?)
  611.          (xp.lp<-bp xp)
  612.          (- (xp.tp<-bp xp) (xp.section-start xp))))
  613.        (new
  614.          (if (zero? colinc)
  615.          (if relative? (+ current colnum) (max colnum current))
  616.          (cond (relative?
  617.             (* colinc
  618.                (quotient (+ current colnum colinc -1) colinc)))
  619.                ((> colnum current) colnum)
  620.                (else
  621.             (+ colnum
  622.                (* colinc
  623.                   (quotient (+ current (- colnum) colinc)
  624.                     colinc)))))))
  625.        (end (- new current)))
  626.       (when (positive? end)
  627.     (if (xp.char-mode xp) (xp.handle-char-mode xp #\space))
  628.     (let ((end (+ (xp.buffer-ptr xp) end)))
  629.       (xp.check-buffer-size xp end)
  630.       (string-fill (xp.buffer xp) #\space (xp.buffer-ptr xp) end)
  631.       (setf (xp.buffer-ptr xp) end))))))
  632.  
  633.  
  634. ;;; note following is smallest number >= x that is a multiple of colinc
  635. ;;;  (* colinc (quotient (+ x (1- colinc)) colinc))
  636.  
  637.  
  638. (define (xp.pprint-newline+ kind xp)
  639.   (xp.enqueue xp 'newline kind)
  640.   (do ((ptr (xp.qleft xp) (xp.qnext ptr)))    ;find sections we are ending
  641.       ((not (< ptr (xp.qright xp))))    ;all but last
  642.     (when (and (not (xp.qend xp ptr))
  643.            (not (> (xp.depth-in-blocks xp) (xp.qdepth xp ptr)))
  644.            (memq (xp.qtype xp ptr) '(newline start-block)))
  645.       (setf (xp.qend xp ptr) (- (xp.qright xp) ptr))))
  646.   (setf (xp.section-start xp) (xp.tp<-bp xp))
  647.   (when (and (memq kind '(fresh unconditional)) (xp.char-mode xp))
  648.     (xp.handle-char-mode xp #\newline))
  649.   (when (memq kind '(fresh unconditional mandatory))
  650.     (xp.attempt-to-output xp '#t '#f)))
  651.  
  652.  
  653. (define (xp.start-block xp prefix-string on-each-line? suffix-string)
  654.   (xp.write-prefix-suffix prefix-string xp)
  655.   (if (and (xp.char-mode xp) on-each-line?)
  656.       (setf prefix-string
  657.         (substring (xp.buffer xp)
  658.                (- (xp.buffer-ptr xp) (string-length prefix-string))
  659.                (xp.buffer-ptr xp))))
  660.   (xp.push-block-stack xp)
  661.   (xp.enqueue xp 'start-block '#f
  662.        (if on-each-line? (cons suffix-string prefix-string) suffix-string))
  663.   (incf (xp.depth-in-blocks xp))          ;must be after enqueue
  664.   (setf (xp.section-start xp) (xp.tp<-bp xp)))
  665.  
  666.  
  667. (define (xp.end-block xp suffix)
  668.   (unless (and (dynamic *xp.abbreviation-happened*)
  669.            (eqv? (dynamic *xp.abbreviation-happened*)
  670.              (dynamic *print-lines*)))
  671.     (xp.write-prefix-suffix suffix xp)
  672.     (decf (xp.depth-in-blocks xp))
  673.     (xp.enqueue xp 'end-block '#f suffix)
  674.     (block foundit
  675.       (do ((ptr (xp.qleft xp) (xp.qnext ptr))) ;look for start of block we are ending
  676.       ((not (< ptr (xp.qright xp))))    ;all but last
  677.       (when (and (= (xp.depth-in-blocks xp) (xp.qdepth xp ptr))
  678.              (eq? (xp.qtype xp ptr) 'start-block)
  679.              (not (xp.qoffset xp ptr)))
  680.         (setf (xp.qoffset xp ptr) (- (xp.qright xp) ptr))
  681.         (return-from foundit '#f)))    ;can only be 1
  682.       )
  683.     (xp.pop-block-stack xp)))
  684.  
  685. (define (xp.write-prefix-suffix mystring xp)
  686.   (when mystring
  687.     (xp.write-string++ mystring xp 0 (string-length mystring))))
  688.  
  689. (define (xp.pprint-indent+ kind n xp)
  690.   (xp.enqueue xp 'ind kind n))
  691.  
  692.  
  693. ;;; attempt-to-output scans the queue looking for things it can do.
  694. ;;; it keeps outputting things until the queue is empty, or it finds
  695. ;;; a place where it cannot make a decision yet.
  696. ;;; If flush-out? is T and force-newlines? is NIL then the buffer,
  697. ;;; prefix-stack, and queue will be in an inconsistent state after the call.
  698. ;;; You better not call it this way except as the last act of outputting.
  699.  
  700.  
  701. (define-local-syntax (xp.maybe-too-large xp Qentry)
  702.   `(let ((limit (xp.linel ,xp)))
  703.      (when (eqv? (xp.line-limit ,xp) (xp.line-no ,xp)) ;prevents suffix overflow
  704.        (decf limit 2) ;3 for " .." minus 1 for space (heuristic)
  705.        (when (not (negative? (xp.prefix-stack-ptr ,xp)))
  706.      (decf limit (xp.suffix-ptr ,xp))))
  707.      (cond ((xp.qend ,xp ,Qentry)
  708.         (> (xp.lp<-tp ,xp (xp.qpos ,xp (+ ,Qentry (xp.qend ,xp ,Qentry)))) limit))
  709.        ((or force-newlines? (> (xp.lp<-bp ,xp) limit))
  710.         '#t)
  711.        (else ;wait until later to decide.
  712.         (return-from attempt-to-output '#f)))))
  713.  
  714. (define-local-syntax (xp.misering? xp)
  715.   `(and (dynamic *print-miser-width*)
  716.     (<= (- (xp.linel ,xp) (initial-prefix-ptr ,xp))
  717.         (dynamic *print-miser-width*))))
  718.  
  719. (define (xp.attempt-to-output xp force-newlines? flush-out?)
  720.   (block attempt-to-output
  721.     (do ()
  722.     ((> (xp.qleft xp) (xp.qright xp))
  723.      (setf (xp.qleft xp) 0)
  724.      (setf (xp.qright xp) (- xp.queue-entry-size))) ;saves shifting
  725.       (case (xp.qtype xp (xp.qleft xp))
  726.         ((ind)
  727.          (unless (xp.misering? xp)
  728.            (xp.set-indentation-prefix
  729.            xp
  730.            (case (xp.qkind xp (xp.qleft xp))
  731.              ((block)
  732.               (+ (initial-prefix-ptr xp) (xp.qarg xp (xp.qleft xp))))
  733.              (else ; current
  734.               (+ (xp.lp<-tp xp (xp.qpos xp (xp.qleft xp)))
  735.                  (xp.qarg xp (xp.qleft xp)))))))
  736.          (setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))
  737.         ((start-block)
  738.          (cond ((xp.maybe-too-large xp (xp.qleft xp))
  739.             (xp.push-prefix-stack xp)
  740.             (setf (initial-prefix-ptr xp) (xp.prefix-ptr xp))
  741.             (xp.set-indentation-prefix
  742.                 xp (xp.lp<-tp xp (xp.qpos xp (xp.qleft xp))))
  743.             (let ((arg (xp.qarg xp (xp.qleft xp))))
  744.               (when (pair? arg) (xp.set-prefix xp (cdr arg)))
  745.               (setf (initial-prefix-ptr xp) (xp.prefix-ptr xp))
  746.               (cond ((not (list? arg)) (xp.set-suffix xp arg))
  747.                 ((car arg) (xp.set-suffix xp (car arg)))))
  748.             (setf (xp.section-start-line xp) (xp.line-no xp)))
  749.            (else (incf (xp.qleft xp) (xp.qoffset xp (xp.qleft xp)))))
  750.          (setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))
  751.         ((end-block)
  752.          (xp.pop-prefix-stack xp)
  753.          (setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))
  754.         (else ; newline
  755.          (when (case (xp.qkind xp (xp.qleft xp))
  756.              ((fresh) (not (zero? (xp.lp<-bp xp))))
  757.              ((miser) (xp.misering? xp))
  758.              ((fill) (or (xp.misering? xp)
  759.                       (> (xp.line-no xp) (xp.section-start-line xp))
  760.                       (xp.maybe-too-large xp (xp.qleft xp))))
  761.              (else '#t)) ;(linear unconditional mandatory) 
  762.            (xp.output-line xp (xp.qleft xp))
  763.            (xp.setup-for-next-line xp (xp.qleft xp)))
  764.          (setf (xp.qleft xp) (xp.qnext (xp.qleft xp)))))))
  765.   (when flush-out? (xp.flush xp)))
  766.  
  767.  
  768. ;;; this can only be called last!
  769.  
  770. (define (xp.flush xp)
  771.   (unless (dynamic *xp.locating-circularities*)
  772.     (internal-write-string (xp.buffer xp) (xp.base-stream xp) 0 (xp.buffer-ptr xp)))
  773.   (incf (xp.buffer-offset xp) (xp.buffer-ptr xp))
  774.   (incf (xp.charpos xp) (xp.buffer-ptr xp))
  775.   (setf (xp.buffer-ptr xp) 0))
  776.  
  777.  
  778. ;;; This prints out a line of stuff.
  779.  
  780. (define (xp.output-line xp Qentry)
  781.   (let* ((out-point (xp.bp<-tp xp (xp.qpos xp Qentry)))
  782.      (last-non-blank (string-position-not-from-end
  783.                  #\space (xp.buffer xp) 0 out-point))
  784.      (end (cond ((memq (xp.qkind xp Qentry) '(fresh unconditional))
  785.              out-point)
  786.             (last-non-blank (1+ last-non-blank))
  787.             (else 0)))
  788.      (line-limit-exit (and (xp.line-limit xp)
  789.                    (not (> (xp.line-limit xp) (xp.line-no xp))))))
  790.     (when line-limit-exit
  791.       (setf (xp.buffer-ptr xp) end)          ;truncate pending output.
  792.       (xp.write-string+++ " .." xp 0 3)
  793.       (string-nreverse (xp.suffix xp) 0 (xp.suffix-ptr xp))
  794.       (xp.write-string+++ (xp.suffix xp) xp 0 (xp.suffix-ptr xp))
  795.       (setf (xp.qleft xp) (xp.qnext (xp.qright xp)))
  796.       (setf (dynamic *xp.abbreviation-happened*) (dynamic *print-lines*))
  797.       (funcall (dynamic *xp.line-limit-abbreviation-exit*) '#t))
  798.     (incf (xp.line-no xp))
  799.     (unless (dynamic *xp.locating-circularities*)
  800.       (internal-write-string (xp.buffer xp) (xp.base-stream xp) 0 end)
  801.       (newline (xp.base-stream xp)))))
  802.  
  803. (define (xp.setup-for-next-line xp Qentry)
  804.   (let* ((out-point (xp.bp<-tp xp (xp.qpos xp Qentry)))
  805.      (prefix-end
  806.        (cond ((memq (xp.qkind xp Qentry) '(unconditional fresh))
  807.           (non-blank-prefix-ptr xp))
  808.          (else (xp.prefix-ptr xp))))
  809.      (change (- prefix-end out-point)))
  810.     (setf (xp.charpos xp) 0)
  811.     (when (positive? change)                  ;almost never happens
  812.       (xp.check-buffer-size xp (+ (xp.buffer-ptr xp) change)))
  813.     (string-replace (xp.buffer xp) (xp.buffer xp)
  814.             prefix-end out-point (xp.buffer-ptr xp))
  815.     (string-replace (xp.buffer xp) (xp.prefix xp) 0 0 prefix-end)
  816.     (incf (xp.buffer-ptr xp) change)
  817.     (decf (xp.buffer-offset xp) change)
  818.     (when (not (memq (xp.qkind xp Qentry) '(unconditional fresh)))
  819.       (setf (xp.section-start-line xp) (xp.line-no xp)))))
  820.  
  821. (define (xp.set-indentation-prefix xp new-position)
  822.   (let ((new-ind (max (non-blank-prefix-ptr xp) new-position)))
  823.     (setf (xp.prefix-ptr xp) (initial-prefix-ptr xp))
  824.     (xp.check-prefix-size xp new-ind)
  825.     (when (> new-ind (xp.prefix-ptr xp))
  826.       (string-fill (xp.prefix xp) #\space (xp.prefix-ptr xp) new-ind))
  827.     (setf (xp.prefix-ptr xp) new-ind)))
  828.  
  829. (define (xp.set-prefix xp prefix-string)
  830.   (let ((end  (string-length prefix-string)))
  831.     (string-replace (xp.prefix xp) prefix-string
  832.             (- (xp.prefix-ptr xp) end) 0 end))
  833.   (setf (non-blank-prefix-ptr xp) (xp.prefix-ptr xp)))
  834.  
  835. (define (xp.set-suffix xp suffix-string)
  836.   (let* ((end (string-length suffix-string))
  837.      (new-end (+ (xp.suffix-ptr xp) end)))
  838.     (xp.check-suffix-size xp new-end)
  839.     (do ((i (1- new-end) (1- i))
  840.      (j 0 (1+ j)))
  841.     ((= j end))
  842.       (setf (string-ref (xp.suffix xp) i) (string-ref suffix-string j)))
  843.     (setf (xp.suffix-ptr xp) new-end)))
  844.  
  845.  
  846. ;;;=====================================================================
  847. ;;; Basic interface functions
  848. ;;;=====================================================================
  849.  
  850. ;;; The internal functions in this file
  851. ;;; use the '+' forms of these functions directly (which is faster) because,
  852. ;;; they do not need error checking of fancy stream coercion.  The '++' forms
  853. ;;; additionally assume the thing being output does not contain a newline.
  854.  
  855. (define (write object . maybe-stream)
  856.   (let ((stream  (if (not (null? maybe-stream))
  857.              (car maybe-stream)
  858.              (current-output-port))))
  859.     (cond ((xp.xp-structure-p stream)
  860.        (xp.write+ object stream))
  861.       ((xp.get-printer object)
  862.        (xp.initiate-xp-printing
  863.          (lambda (s o) (xp.write+ o s))
  864.          stream
  865.          object))
  866.       (else
  867.        (internal-write object stream)))))
  868.  
  869. (define (xp.maybe-initiate-xp-printing fn stream . args)
  870.   (if (xp.xp-structure-p stream)
  871.       (apply fn stream args)
  872.       (apply (function xp.initiate-xp-printing) fn stream args)))
  873.  
  874. (define (xp.initiate-xp-printing fn stream . args)
  875.   (dynamic-let ((*xp.abbreviation-happened*
  876.             '#f)
  877.         (*xp.locating-circularities*
  878.             (if (dynamic *print-circle*)
  879.             0
  880.             '#f))
  881.         (*xp.circularity-hash-table*
  882.             (if (dynamic *print-circle*)
  883.             (make-table)
  884.             '#f))
  885.         (*xp.parents*
  886.             (if (not (dynamic *print-shared*))
  887.             (list '#f)
  888.             '()))            ;*** is this right?
  889.         (*xp.current-level*
  890.             0)
  891.         (*xp.current-length*
  892.             0))
  893.     (let ((result  (xp.xp-print fn stream args)))
  894.       (when (dynamic *xp.abbreviation-happened*)
  895.     (setf args (list-copy args))
  896.     (setf (dynamic *last-abbreviated-printing*)
  897.           (lambda maybe-stream
  898.         (let ((stream  (if (not (null? maybe-stream))
  899.                    (car maybe-stream)
  900.                    stream)))
  901.           (apply (function xp.maybe-initiate-xp-printing)
  902.              fn stream args)))))
  903.       result)))
  904.  
  905. (define (xp.xp-print fn stream args)
  906.   (let ((result  (xp.do-xp-printing fn stream args)))
  907.     (when (dynamic *xp.locating-circularities*)
  908.       (setf (dynamic *xp.locating-circularities*) '#f)
  909.       (setf (dynamic *xp.abbreviation-happened*) '#f)
  910.       (setf (dynamic *xp.parents*) '())
  911.       (setf result (xp.do-xp-printing fn stream args)))
  912.     result))
  913.  
  914. (define (xp.do-xp-printing fn stream args)
  915.   (let ((xp (xp.get-pretty-print-stream stream))
  916.     (result '#f))
  917.     (dynamic-let ((*xp.current-level* 0))
  918.       (let/cc catch
  919.         (dynamic-let ((*xp.line-limit-abbreviation-exit* catch))
  920.       (xp.start-block xp '#f '#f '#f)
  921.       (setf result (apply fn xp args))
  922.       (xp.end-block xp '#f)))
  923.       (when (and (dynamic *xp.locating-circularities*)
  924.          (zero? (dynamic *xp.locating-circularities*)) ;No circularities.
  925.          (= (xp.line-no xp) 1)             ;Didn't suppress line.
  926.          (zero? (xp.buffer-offset xp)))    ;Didn't suppress partial line.
  927.     (setf (dynamic *xp.locating-circularities*) '#f))    ;print what you have got.
  928.       (when (let/cc catch
  929.           (dynamic-let ((*xp.line-limit-abbreviation-exit* catch))
  930.             (xp.attempt-to-output xp '#f '#t)
  931.         '#f))
  932.     (xp.attempt-to-output xp '#t '#t))
  933.       (xp.free-pretty-print-stream xp)
  934.       result)))
  935.  
  936.  
  937. (define (xp.write+ object xp)
  938.   (dynamic-let ((*xp.parents* (dynamic *xp.parents*)))
  939.     (unless (and (dynamic *xp.circularity-hash-table*)
  940.          (eq? (xp.circularity-process xp object '#f) 'subsequent))
  941.       (when (and (dynamic *xp.circularity-hash-table*) (pair? object))
  942.     ;; Must do this to avoid additional circularity detection by
  943.         ;; pprint-logical-block; otherwise you get stuff like #1=#1#.
  944.     (setf object (cons (car object) (cdr object))))
  945.       (funcall (or (xp.get-printer object) (function xp.print-default))
  946.            object
  947.            xp))
  948.     object))
  949.  
  950.  
  951.  
  952. (define (xp.print-default object xp)
  953.   (let ((stuff (internal-write-to-string object)))
  954.     (xp.write-string+ stuff xp 0 (string-length stuff))))
  955.  
  956.  
  957. ;;; It is vital that this function be called EXACTLY once for each occurrence 
  958. ;;;   of each thing in something being printed.
  959. ;;; Returns nil if printing should just continue on.
  960. ;;;   Either it is not a duplicate, or we are in the first pass and do not 
  961. ;;;   know.
  962. ;;; returns :FIRST if object is first occurrence of a DUPLICATE.
  963. ;;;   (This can only be returned on a second pass.)
  964. ;;;   After an initial code (printed by this routine on the second pass)
  965. ;;;   printing should continue on for the object.
  966. ;;; returns :SUBSEQUENT if second or later occurrence.
  967. ;;;   Printing is all taken care of by this routine.
  968.  
  969. ;;; Note many (maybe most) lisp implementations have characters and small 
  970. ;;; numbers represented in a single word so that the are always eq when 
  971. ;;; they are equal and the reader takes care of properly sharing them 
  972. ;;; (just as it does with symbols).  Therefore, we do not want circularity 
  973. ;;; processing applied to them.  However, some kinds of numbers 
  974. ;;; (e.g., bignums) undoubtedly are complex structures that the reader 
  975. ;;; does not share.  However, they cannot have circular pointers in them
  976. ;;; and it is therefore probably a waste to do circularity checking on them.  
  977. ;;; In any case, it is not clear that it easy to tell exactly what kinds of 
  978. ;;; numbers a given implementation is going to have the reader 
  979. ;;; automatically share.
  980.  
  981. (define (xp.circularity-process xp object interior-cdr?)
  982.   (unless (or (number? object)
  983.           (char? object)
  984.           (and (symbol? object) (not (gensym? object))))
  985.     (let ((id (table-entry (dynamic *xp.circularity-hash-table*) object)))
  986.       (if (dynamic *xp.locating-circularities*)
  987.       ;; This is the first pass.
  988.       (cond ((not id)    ;never seen before
  989.          (when (not (null? (dynamic *xp.parents*)))
  990.            (push object (dynamic *xp.parents*)))
  991.          (setf (table-entry (dynamic *xp.circularity-hash-table*) object)
  992.                0)
  993.          '#f)
  994.         ((zero? id) ;possible second occurrence
  995.          (cond ((or (null? (dynamic *xp.parents*))
  996.                 (memq object (dynamic *xp.parents*)))
  997.             (setf (table-entry
  998.                       (dynamic *xp.circularity-hash-table*) object)
  999.                   (incf (dynamic *xp.locating-circularities*)))
  1000.             'subsequent)
  1001.                (else '#f)))
  1002.         (else 'subsequent));third or later occurrence
  1003.       ;; This is the second pass.
  1004.       (cond ((or (not id)    ;never seen before (note ~@* etc. conses)
  1005.              (zero? id));no duplicates
  1006.          '#f)
  1007.         ((positive? id) ; first occurrence
  1008.          (cond (interior-cdr?
  1009.             (decf (dynamic *xp.current-level*))
  1010.             (xp.write-string++ ". #" xp 0 3))
  1011.                (else (xp.write-char++ #\# xp)))
  1012.          (xp.print-integer id xp)
  1013.          (xp.write-char++ #\= xp)
  1014.          (setf (table-entry (dynamic *xp.circularity-hash-table*) object)
  1015.                (- id))
  1016.          'first)
  1017.         (else
  1018.          (if interior-cdr?
  1019.              (xp.write-string++ ". #" xp 0 3)
  1020.              (xp.write-char++ #\# xp))
  1021.          (xp.print-integer(- id) xp)
  1022.          (xp.write-char++ #\# xp)
  1023.          'subsequent))))))
  1024.  
  1025.  
  1026. ;;; Here are all the standard Common Lisp printing functions.
  1027.  
  1028. (define (print object . maybe-stream)
  1029.   (let ((stream  (if (not (null? maybe-stream))
  1030.              (car maybe-stream)
  1031.              (current-output-port))))
  1032.     (dynamic-let ((*print-escape* '#t))
  1033.       (terpri stream)
  1034.       (write object stream)
  1035.       (write-char #\space stream)
  1036.       object)))
  1037.  
  1038. (define (prin1 object . maybe-stream)
  1039.   (let ((stream  (if (not (null? maybe-stream))
  1040.              (car maybe-stream)
  1041.              (current-output-port))))
  1042.     (dynamic-let ((*print-escape* '#t))
  1043.       (write object stream)
  1044.       object)))
  1045.  
  1046. (define (princ object . maybe-stream)
  1047.   (let ((stream  (if (not (null? maybe-stream))
  1048.              (car maybe-stream)
  1049.              (current-output-port))))
  1050.     (dynamic-let ((*print-escape* '#f))
  1051.       (write object stream)
  1052.       object)))
  1053.  
  1054. (define (display object . maybe-stream)
  1055.   (apply (function princ) object maybe-stream))
  1056.  
  1057.  
  1058. (define (pprint object . maybe-stream)
  1059.   (let ((stream  (if (not (null? maybe-stream))
  1060.              (car maybe-stream)
  1061.              (current-output-port))))
  1062.     (dynamic-let ((*print-escape* '#t)
  1063.           (*print-pretty* '#t))
  1064.       (terpri stream)
  1065.       (write object stream)
  1066.       (values))))
  1067.  
  1068. (define (prin1-to-string object)
  1069.   (call-with-output-string
  1070.       (lambda (stream)
  1071.     (dynamic-let ((*print-escape* '#t))
  1072.       (write object stream)))))
  1073.  
  1074. (define (princ-to-string object)
  1075.   (call-with-output-string
  1076.       (lambda (stream)
  1077.     (dynamic-let ((*print-escape* '#f))
  1078.       (write object stream)))))
  1079.  
  1080.  
  1081.  
  1082. (define (write-char char . maybe-stream)
  1083.   (let ((stream  (if (not (null? maybe-stream))
  1084.              (car maybe-stream)
  1085.              (current-output-port))))
  1086.     (if (xp.xp-structure-p stream)
  1087.     (xp.write-char+ char stream)
  1088.     (internal-write-char char stream))
  1089.     char))
  1090.  
  1091. (define (write-string mystring . maybe-stream-start-end)
  1092.   (let* ((stream  (if (not (null? maybe-stream-start-end))
  1093.               (car maybe-stream-start-end)
  1094.               (current-output-port)))
  1095.      (start   (if (not (null? (cdr maybe-stream-start-end)))
  1096.               (cadr maybe-stream-start-end)
  1097.               0))
  1098.      (end     (if (not (null? (cddr maybe-stream-start-end)))
  1099.               (caddr maybe-stream-start-end)
  1100.               (string-length mystring))))
  1101.     (if (xp.xp-structure-p stream)
  1102.     (xp.write-string+ mystring stream start end)
  1103.     (internal-write-string mystring stream start end))
  1104.     mystring))
  1105.  
  1106. (define (write-line mystring . maybe-stream-start-end)
  1107.   (let* ((stream  (if (not (null? maybe-stream-start-end))
  1108.               (car maybe-stream-start-end)
  1109.               (current-output-port)))
  1110.      (start   (if (not (null? (cdr maybe-stream-start-end)))
  1111.               (cadr maybe-stream-start-end)
  1112.               0))
  1113.      (end     (if (not (null? (cddr maybe-stream-start-end)))
  1114.               (caddr maybe-stream-start-end)
  1115.               (string-length mystring))))
  1116.     (if (xp.xp-structure-p stream)
  1117.     (begin
  1118.       (xp.write-string+ mystring stream start end)
  1119.       (xp.pprint-newline+ 'unconditional stream))
  1120.     (begin 
  1121.       (internal-write-string mystring stream start end)
  1122.       (internal-newline stream)))
  1123.     mystring))
  1124.  
  1125. (define (terpri . maybe-stream)
  1126.   (let ((stream  (if (not (null? maybe-stream))
  1127.              (car maybe-stream)
  1128.              (current-output-port))))
  1129.     (if (xp.xp-structure-p stream)
  1130.     (xp.pprint-newline+ 'unconditional stream)
  1131.     (internal-newline stream))
  1132.     '#f))
  1133.  
  1134. (define (newline . maybe-stream)
  1135.   (apply (function terpri) maybe-stream))
  1136.  
  1137.  
  1138. ;;; This has to violate the XP data abstraction and fool with internal
  1139. ;;; stuff, in order to find out the right info to return as the result.
  1140.  
  1141. (define (fresh-line . maybe-stream)
  1142.   (let ((stream  (if (not (null? maybe-stream))
  1143.              (car maybe-stream)
  1144.              (current-output-port))))
  1145.     (cond ((xp.xp-structure-p stream)
  1146.        (xp.attempt-to-output stream '#t '#t) ;ok because we want newline
  1147.        (when (not (zero? (xp.lp<-bp stream)))
  1148.          (xp.pprint-newline+ 'fresh stream)
  1149.          '#t))
  1150.       (else
  1151.        (internal-fresh-line stream)))))
  1152.  
  1153.  
  1154. ;;; Each of these causes the stream to be pessimistic and insert
  1155. ;;; newlines wherever it might have to, when forcing the partial output
  1156. ;;; out.  This is so that things will be in a consistent state if
  1157. ;;; output continues to the stream later.
  1158.  
  1159. (define (finish-output . maybe-stream)
  1160.   (let ((stream  (if (not (null? maybe-stream))
  1161.              (car maybe-stream)
  1162.              (current-output-port))))
  1163.     (if (xp.xp-structure-p stream)
  1164.     (xp.attempt-to-output stream '#t '#t)
  1165.     (internal-finish-output stream))
  1166.     '#f))
  1167.  
  1168. (define (force-output . maybe-stream)
  1169.   (let ((stream  (if (not (null? maybe-stream))
  1170.              (car maybe-stream)
  1171.              (current-output-port))))
  1172.     (if (xp.xp-structure-p stream)
  1173.     (xp.attempt-to-output stream '#t '#t)
  1174.     (internal-force-output stream))
  1175.     '#f))
  1176.  
  1177. (define (clear-output . maybe-stream)
  1178.   (let ((stream  (if (not (null? maybe-stream))
  1179.              (car maybe-stream)
  1180.              (current-output-port))))
  1181.     (if (xp.xp-structure-p stream)
  1182.     (dynamic-let ((*xp.locating-circularities* 0)) ;hack to prevent visible output
  1183.       (xp.attempt-to-output stream '#t '#t)
  1184.     (internal-clear-output stream)))
  1185.     '#f))
  1186.    
  1187.  
  1188.  
  1189.  
  1190. ;;;=====================================================================
  1191. ;;; Functional interface to dynamic formatting
  1192. ;;;=====================================================================
  1193.  
  1194. ;;; The internal functions in this file, and the (formatter "...") expansions
  1195. ;;; use the '+' forms of these functions directly (which is faster) because,
  1196. ;;; they do not need error checking or fancy stream coercion.  The '++' forms
  1197. ;;; additionally assume the thing being output does not contain a newline.
  1198.  
  1199. (define-syntax (pprint-logical-block stream-symbol-stuff . body)
  1200.   (let* ((stream-symbol    (car stream-symbol-stuff))
  1201.      (mylist             (cadr stream-symbol-stuff))
  1202.      (rest             (cddr stream-symbol-stuff))
  1203.      (prefix           (if (not (null? rest)) (pop rest) ""))
  1204.      (suffix           (if (not (null? rest)) (pop rest) ""))
  1205.      (per-line?        (if (not (null? rest)) (pop rest) '#f)))
  1206.     `(xp.maybe-initiate-xp-printing
  1207.        (lambda (,stream-symbol)
  1208.      (let ((+l ,mylist)
  1209.            (+p ,prefix)
  1210.            (+s ,suffix)
  1211.            (+x ,stream-symbol))
  1212.        (xp.pprint-logical-block+ (+x +l +p +s ,per-line? '#t '#f)
  1213.          ,@body
  1214.          '#f)))
  1215.        ,stream-symbol)))
  1216.  
  1217.  
  1218. ;;; Assumes var and args must be variables.  Other arguments must be literals 
  1219. ;;; or variables.
  1220.  
  1221. (define-syntax (xp.pprint-logical-block+ stuff . body)
  1222.   (let* ((var            (pop stuff))
  1223.      (args           (pop stuff))
  1224.      (prefix         (pop stuff))
  1225.      (suffix         (pop stuff))
  1226.      (per-line?      (pop stuff)))
  1227.     `(unless (xp.check-abbreviation ,var ,args)
  1228.        (dynamic-let ((*xp.current-level* (1+ (dynamic *xp.current-level*)))
  1229.              (*xp.current-length* -1)
  1230.              (*xp.parents* (dynamic *xp.parents*)))
  1231.      (block logical-block
  1232.        (if (dynamic *print-pretty*)
  1233.            (xp.start-block ,var ,prefix ,per-line? ,suffix)
  1234.            (xp.write-prefix-suffix ,prefix ,var))
  1235.        (unwind-protect
  1236.            (begin ,@body)
  1237.          (if (dynamic *print-pretty*)
  1238.          (xp.end-block ,var ,suffix)
  1239.          (xp.write-prefix-suffix ,suffix ,var))))))
  1240.     ))
  1241.  
  1242. (define (xp.check-abbreviation xp object)
  1243.   (cond ((and (dynamic *print-level*)
  1244.           (>= (dynamic *xp.current-level*)
  1245.           (dynamic *print-level*)))
  1246.      (xp.write-char++ #\# XP)
  1247.      (setf (dynamic *xp.abbreviation-happened*) '#t)
  1248.      '#t)
  1249.     ((and (dynamic *xp.circularity-hash-table*)
  1250.           (eq? (xp.circularity-process xp object '#f) 'subsequent))
  1251.      '#t)
  1252.     (else '#f)))
  1253.  
  1254.  
  1255. (define-syntax (pprint-pop)
  1256.   `(xp.pprint-pop+ +l +x))
  1257.  
  1258. (define-syntax (xp.pprint-pop+ args xp)
  1259.   `(if (xp.pprint-pop-check+ ,args ,xp)
  1260.        (return-from logical-block '#f)
  1261.        (if (null? ,args) '() (pop ,args))))
  1262.  
  1263. (define (xp.pprint-pop-check+ args xp)
  1264.   (incf (dynamic *xp.current-length*))
  1265.   (cond ((not (or (pair? args) (null? args)))
  1266.      ;; must be first to supersede length abbreviation
  1267.      (xp.write-string++ ". " xp 0 2)
  1268.      (xp.write+ args xp)
  1269.      '#t)
  1270.     ((and (dynamic *print-length*)
  1271.           (not (< *xp.current-length* (dynamic *print-length*))))
  1272.      ;; must supersede circularity check
  1273.      (xp.write-string++ "..." xp 0 3)
  1274.      (setf (dynamic *xp.abbreviation-happened*) '#t)
  1275.      '#t)
  1276.     ((and (dynamic *xp.circularity-hash-table*)
  1277.           (not (zero? *xp.current-length*)))
  1278.      (case (xp.circularity-process xp args '#t)
  1279.            ((first)
  1280.         (xp.write+ (cons (car args) (cdr args)) xp) '#t)
  1281.            ((subsequent)
  1282.         '#t)
  1283.            (else
  1284.         '#f)))
  1285.     (else
  1286.      '#f)))
  1287.  
  1288. (define-syntax (pprint-exit-if-list-exhausted)
  1289.   `(xp.pprint-exit-if-list-exhausted+ +l))
  1290.  
  1291. (define-syntax (xp.pprint-exit-if-list-exhausted+ mylist)
  1292.   `(if (null? ,mylist) (return-from logical-block '#f)))
  1293.  
  1294.  
  1295. (define (pprint-newline kind . maybe-stream)
  1296.   (let ((stream  (if (not (null? maybe-stream))
  1297.              (car maybe-stream)
  1298.              (current-output-port))))
  1299.     (when (not (memq kind '(linear miser fill mandatory)))
  1300.       (error "Invalid KIND argument ~A to PPRINT-NEWLINE" kind))
  1301.     (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*))
  1302.       (xp.pprint-newline+ kind stream))
  1303.     '#f))
  1304.  
  1305. (define (pprint-indent relative-to n . maybe-stream)
  1306.   (let ((stream  (if (not (null? maybe-stream))
  1307.              (car maybe-stream)
  1308.              (current-output-port))))
  1309.     (when (not (memq relative-to '(block current)))
  1310.       (error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to))
  1311.     (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*))
  1312.       (xp.pprint-indent+ relative-to n stream))
  1313.     '#f))
  1314.  
  1315. (define (pprint-tab kind colnum colinc . maybe-stream)
  1316.   (let ((stream  (if (not (null? maybe-stream))
  1317.              (car maybe-stream)
  1318.              (current-output-port))))
  1319.     (when (not (memq kind '(line section line-relative section-relative)))
  1320.       (error "Invalid KIND argument ~A to PPRINT-TAB" kind))
  1321.     (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*))
  1322.       (xp.pprint-tab+ kind colnum colinc stream))
  1323.     '#f))
  1324.  
  1325.  
  1326.  
  1327.  
  1328. ;;;=====================================================================
  1329. ;;; Standard print dispatch function
  1330. ;;;=====================================================================
  1331.  
  1332.  
  1333. (define (xp.print-null object xp)
  1334.   (declare (ignore object))
  1335.   (xp.write-string+ "()" xp 0 2))
  1336.  
  1337. (define (xp.print-true object xp)
  1338.   (declare (ignore object))
  1339.   (xp.write-string+ "#t" xp 0 2))
  1340.  
  1341. (define (xp.print-false object xp)
  1342.   (declare (ignore object))
  1343.   (xp.write-string+ "#f" xp 0 2))
  1344.  
  1345. (define (xp.print-symbol object xp)
  1346.   (if (dynamic *print-escape*)
  1347.       (xp.print-default object xp)
  1348.       (let ((mystring  (symbol->string object)))
  1349.     (xp.write-string+ mystring xp 0 (string-length mystring)))))
  1350.  
  1351. (define (xp.print-number object xp)
  1352.   (if (and (integer? object)
  1353.        (eqv? (dynamic *print-base*) 10)
  1354.        (not (dynamic *print-radix*)))
  1355.       (begin
  1356.         (when (negative? object)
  1357.       (xp.write-char++ #\- xp)
  1358.       (setf object (- object)))
  1359.     (xp.print-integer object xp))
  1360.       (xp.print-default object xp)))
  1361.  
  1362. (define (xp.print-integer n xp)
  1363.   (let ((quot  (quotient n 10))
  1364.     (rem   (remainder n 10)))
  1365.     (unless (zero? quot)
  1366.       (xp.print-integer quot xp))
  1367.     (xp.write-char++ (string-ref "0123456789" rem) xp)))
  1368.  
  1369. (define (xp.print-string object xp)
  1370.   (if (dynamic *print-escape*)
  1371.       (begin
  1372.         (xp.write-char++ #\" xp)
  1373.     (do ((i 0 (1+ i))
  1374.          (n (string-length object)))
  1375.         ((= i n))
  1376.         (let ((c  (string-ref object i)))
  1377.           (if (or (char=? c #\") (char=? c #\\))
  1378.           (xp.write-char++ #\\ xp))
  1379.           (xp.write-char++ c xp)))
  1380.     (xp.write-char++ #\" xp))
  1381.       (xp.write-string+ object xp 0 (string-length object))))
  1382.  
  1383. (define (xp.print-character object xp)
  1384.   (if (dynamic *print-escape*)
  1385.       (let ((name  (char-name object)))
  1386.         (xp.write-char++ #\# xp)
  1387.     (xp.write-char++ #\\ xp)
  1388.     (if name
  1389.         (xp.write-string++ name xp 0 (string-length name))
  1390.         (xp.write-char++ object xp)))
  1391.       (xp.write-char+ object xp)))
  1392.  
  1393. (define (xp.print-vector object xp)
  1394.   (let* ((pretty?  (dynamic *print-pretty*))
  1395.      (end      (vector-length object)))
  1396.     (pprint-logical-block (xp '() "#(" ")")
  1397.       (do ((i 0 (1+ i)))
  1398.       ((eqv? i end) '#f)
  1399.       (when (not (eqv? i 0))
  1400.         (xp.write-char++ #\space xp)
  1401.         (if pretty?
  1402.         (xp.pprint-newline+ 'fill xp)))
  1403.       (pprint-pop)
  1404.       (xp.write+ (vector-ref object i) xp)
  1405.       ))))
  1406.  
  1407. (define (xp.print-table object xp)
  1408.   (let ((pretty?  (dynamic *print-pretty*)))
  1409.     (pprint-logical-block (xp '() "#<Table" ">")
  1410.       (table-for-each
  1411.         (lambda (key value)
  1412.       (xp.write-char++ #\space xp)
  1413.       (if pretty?
  1414.           (xp.pprint-newline+ 'fill xp))
  1415.       (pprint-pop)
  1416.       (xp.write+ (cons key value) xp))
  1417.     object))))
  1418.  
  1419. (define (xp.print-pair object xp)
  1420.   (if (dynamic *print-pretty*)
  1421.       (xp.pretty-print-list object xp)
  1422.       (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
  1423.     (do ()
  1424.         ((null? object) '#f)
  1425.         (xp.write+ (xp.pprint-pop+ object xp) xp)
  1426.         (when (not (null? object)) (xp.write-char++ #\space xp))))))
  1427.  
  1428. (define (xp.print-struct object xp)
  1429.   (if (dynamic *print-structure*)
  1430.       (print-structure-default object xp)
  1431.       (funcall (get-structure-printer (struct-type-descriptor object))
  1432.            object xp)))
  1433.  
  1434. (define (get-structure-printer td)
  1435.   (or (td-printer td)
  1436.       (if (eq? (td-name td) 'struct)
  1437.           (function print-structure-default)
  1438.           (get-structure-printer (td-parent-type td)))))
  1439.  
  1440.  
  1441.  
  1442. (define (print-structure-default object xp)
  1443.   (let* ((td       (struct-type-descriptor object))
  1444.      (slots    (td-slots td))
  1445.      (pretty?  (dynamic *print-pretty*))
  1446.      (hash     (structure-hash object)))
  1447.     (pprint-logical-block (xp '() "#<Struct " ">")
  1448.       (prin1 (td-name td) xp)
  1449.       (write-char #\space xp)
  1450.       (prin1 hash xp)
  1451.       (when (dynamic *print-structure-slots*)
  1452.     (dolist (s slots)
  1453.       (write-char #\space xp)
  1454.       (if pretty? (pprint-newline 'fill xp))
  1455.       (pprint-pop)
  1456.       (prin1 (sd-name s) xp)
  1457.       (write-char #\space xp)
  1458.       (write (funcall (sd-getter-function s) object) xp)))
  1459.       )))
  1460.  
  1461.  
  1462. ;;; This table can't be initialized until after all the functions
  1463. ;;; have been defined.
  1464.  
  1465. (define *standard-print-dispatch-table*
  1466.   (list (cons (function null?)         (function xp.print-null))
  1467.     (cons (lambda (x) (eq? x '#t)) (function xp.print-true))
  1468.     (cons (function not)           (function xp.print-false))
  1469.     (cons (function symbol?)       (function xp.print-symbol))
  1470.     (cons (function number?)       (function xp.print-number))
  1471.     (cons (function pair?)         (function xp.print-pair))
  1472.     (cons (function string?)       (function xp.print-string))
  1473.     (cons (function char?)         (function xp.print-character))
  1474.     (cons (function struct?)       (function xp.print-struct))
  1475.     (cons (function vector?)       (function xp.print-vector))
  1476.     (cons (function table?)        (function xp.print-table))))
  1477.  
  1478. (define (standard-print-dispatch object)
  1479.   (standard-print-dispatch-aux
  1480.      object (dynamic *standard-print-dispatch-table*)))
  1481.  
  1482. (define (standard-print-dispatch-aux object table)
  1483.   (cond ((null? table) (function xp.print-default))
  1484.     ((funcall (car (car table)) object)
  1485.      (cdr (car table)))
  1486.     (else
  1487.      (standard-print-dispatch-aux object (cdr table)))))
  1488.  
  1489. (setf (dynamic *print-dispatch*) (function standard-print-dispatch))
  1490.  
  1491.  
  1492.  
  1493. ;;;=====================================================================
  1494. ;;; Pretty printing formats for code
  1495. ;;;=====================================================================
  1496.  
  1497.  
  1498. ;;; The standard prettyprinters for lists dispatch off the CAR of the list.
  1499.  
  1500. (define *xp.pair-dispatch-table* (make-table))
  1501.  
  1502. (define (xp.pretty-print-list object xp)
  1503.   (funcall (or (table-entry (dynamic *xp.pair-dispatch-table*) (car object))
  1504.            (if (symbol? (car object)) (function xp.fn-call) '#f)
  1505.            (lambda (object xp)
  1506.          (pprint-fill xp object)))
  1507.        object
  1508.        xp))
  1509.  
  1510.  
  1511. ;;; Must use pprint-logical-block (no +) in the following three, because they 
  1512. ;;; are exported functions.
  1513. ;;; *** Note that the argument order on these is backwards; that's the
  1514. ;;; *** way it is in Common Lisp....
  1515.  
  1516. (define (pprint-linear s object . moreargs)
  1517.   (let* ((colon?  (if (not (null? moreargs)) (pop moreargs) '#t))
  1518.      (atsign? (if (not (null? moreargs)) (pop moreargs) '#f)))
  1519.     (declare (ignore atsign?))
  1520.     (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" ""))
  1521.       (pprint-exit-if-list-exhausted)
  1522.       (do () ('#f)
  1523.       (xp.write+ (pprint-pop) s)
  1524.       (pprint-exit-if-list-exhausted)
  1525.       (xp.write-char++ #\space s)
  1526.       (xp.pprint-newline+ 'linear s)))))
  1527.  
  1528. (define (pprint-fill s object . moreargs)
  1529.   (let* ((colon?  (if (not (null? moreargs)) (pop moreargs) '#t))
  1530.      (atsign? (if (not (null? moreargs)) (pop moreargs) '#f)))
  1531.     (declare (ignore atsign?))
  1532.     (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" ""))
  1533.       (pprint-exit-if-list-exhausted)
  1534.       (do () ('#f)
  1535.       (xp.write+ (pprint-pop) s)
  1536.       (pprint-exit-if-list-exhausted)
  1537.       (xp.write-char++ #\space s)
  1538.       (xp.pprint-newline+ 'fill s)))))
  1539.  
  1540. (define (pprint-tabular s object . moreargs)
  1541.   (let* ((colon?  (if (not (null? moreargs)) (pop moreargs) '#t))
  1542.      (atsign? (if (not (null? moreargs)) (pop moreargs) '#f))
  1543.     (tabsize (or (and (not (null? moreargs)) (pop moreargs)) 16)))
  1544.     (declare (ignore atsign?))
  1545.     (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" ""))
  1546.       (pprint-exit-if-list-exhausted)
  1547.       (do () ('#f)
  1548.       (xp.write+ (pprint-pop) s)
  1549.       (pprint-exit-if-list-exhausted)
  1550.       (xp.write-char++ #\space s)
  1551.       (xp.pprint-tab+ 'section-relative 0 tabsize s)
  1552.       (xp.pprint-newline+ 'fill s)))))
  1553.  
  1554.  
  1555. (define (xp.fn-call object xp)
  1556.   ;; (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>")
  1557.   (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
  1558.     (xp.write+ (xp.pprint-pop+ object xp) xp)
  1559.     (xp.pprint-exit-if-list-exhausted+ object)
  1560.     (xp.write-char++ #\space xp)
  1561.     (xp.pprint-indent+ 'current 0 xp)
  1562.     (xp.pprint-newline+ 'miser xp)
  1563.     (xp.write+ (xp.pprint-pop+ object xp) xp)
  1564.     (do ()
  1565.     ((null? object) '#f)
  1566.     (xp.write-char++ #\space xp)
  1567.     (xp.pprint-newline+ 'linear xp)
  1568.     (xp.write+ (xp.pprint-pop+ object xp) xp))))
  1569.  
  1570.  
  1571. ;;; Although idiosyncratic, I have found this very useful to avoid large
  1572. ;;; indentations when printing out code.
  1573.  
  1574. (define (xp.alternative-fn-call object xp)
  1575.   (if (> (string-length (symbol->string (car object))) 12)
  1576.       ;; (formatter "~:<~1I~@{~W~^ ~_~}~:>")
  1577.       (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
  1578.         (xp.pprint-indent+ 'block 1 xp)
  1579.     (when (not (null? object))
  1580.       (xp.write+ (xp.pprint-pop+ object xp) xp)
  1581.       (do ()
  1582.           ((null? object) '#f)
  1583.           (xp.write-char++ #\space xp)
  1584.           (xp.pprint-newline+ 'linear xp)
  1585.           (xp.write+ (xp.pprint-pop+ object xp) xp))))
  1586.       (xp.fn-call object xp)))
  1587.  
  1588.  
  1589. (define (xp.bind-list object xp . args)
  1590.   (declare (ignore args))
  1591.   ;; (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>")
  1592.   (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
  1593.     (when (not (null? object))
  1594.       (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f)
  1595.       (do ()
  1596.       ((null? object) '#f)
  1597.       (xp.write-char++ #\space xp)
  1598.       (xp.pprint-newline+ 'linear xp)
  1599.       (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f)))))
  1600.  
  1601. (define (xp.fbind-list object xp . args)
  1602.   (declare (ignore args))
  1603.   ;; (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>")
  1604.   (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
  1605.     (when (not (null? object))
  1606.       (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f)
  1607.       (do ()
  1608.       ((null? object) '#f)
  1609.       (xp.write-char++ #\space xp)
  1610.       (xp.pprint-newline+ 'linear xp)
  1611.       (xp.block-like (xp.pprint-pop+ object xp) xp)))))
  1612.  
  1613.  
  1614. (define (xp.block-like object xp . args)
  1615.   (declare (ignore args))
  1616.   ;; (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>")
  1617.   (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
  1618.     (xp.pprint-indent+ 'block 1 xp)
  1619.     (xp.pprint-exit-if-list-exhausted+ object)
  1620.     (xp.write+ (xp.pprint-pop+ object xp) xp)
  1621.     (xp.pprint-exit-if-list-exhausted+ object)
  1622.     (xp.write-char++ #\space xp)
  1623.     (xp.pprint-newline+ 'miser xp)
  1624.     (xp.write+ (xp.pprint-pop+ object xp) xp)
  1625.     (xp.pprint-exit-if-list-exhausted+ object)
  1626.     (do ()
  1627.     ((null? object) '#f)
  1628.     (xp.write-char++ #\space xp)
  1629.     (xp.pprint-newline+ 'linear xp)
  1630.     (xp.write+ (xp.pprint-pop+ object xp) xp))))
  1631.  
  1632.  
  1633. (define (xp.print-fancy-fn-call object xp template)
  1634.   (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
  1635.     (xp.write+ (xp.pprint-pop+ object xp) xp)
  1636.     (xp.pprint-indent+ 'current 1 xp)
  1637.     (do ((i 0 (1+ i))
  1638.      (in-first-section '#t))
  1639.     ((null? object) '#f)
  1640.     (xp.write-char++ #\space xp)
  1641.     (when (eqv? i (car template))
  1642.       (xp.pprint-indent+ 'block (cadr template) xp)
  1643.       (setf template (cddr template))
  1644.       (setf in-first-section '#f))
  1645.     (pprint-newline (cond ((zero? i) 'miser)
  1646.                   (in-first-section 'fill)
  1647.                   (else 'linear))
  1648.             xp)
  1649.     (xp.write+ (xp.pprint-pop+ object xp) xp))))
  1650.  
  1651. (define (xp.let-print object xp)
  1652.   ;; (formatter "~:<~1I~W~^ ~@_~/xp:xp.bind-list/~^~@{ ~_~W~^~}~:>")
  1653.   (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
  1654.     (xp.pprint-indent+ 'block 1 xp)
  1655.     (xp.write+ (xp.pprint-pop+ object xp) xp)
  1656.     (xp.pprint-exit-if-list-exhausted+ object)
  1657.     (xp.write-char++ #\space xp)
  1658.     (xp.pprint-newline+ 'miser xp)
  1659.     (xp.bind-list (xp.pprint-pop+ object xp) xp '#f '#f)
  1660.     (xp.pprint-exit-if-list-exhausted+ object)
  1661.     (do ()
  1662.     ((null? object) '#f)
  1663.     (xp.write-char++ #\space xp)
  1664.     (xp.pprint-newline+ 'linear xp)
  1665.     (xp.write+ (xp.pprint-pop+ object xp) xp))))
  1666.  
  1667. (define (xp.flet-print object xp)
  1668.   (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
  1669.     (xp.pprint-indent+ 'block 1 xp)
  1670.     (xp.write+ (xp.pprint-pop+ object xp) xp)
  1671.     (xp.pprint-exit-if-list-exhausted+ object)
  1672.     (xp.write-char++ #\space xp)
  1673.     (xp.pprint-newline+ 'miser xp)
  1674.     (xp.fbind-list (xp.pprint-pop+ object xp) xp '#f '#f)
  1675.     (xp.pprint-exit-if-list-exhausted+ object)
  1676.     (do ()
  1677.     ((null? object) '#f)
  1678.     (xp.write-char++ #\space xp)
  1679.     (xp.pprint-newline+ 'linear xp)
  1680.     (xp.write+ (xp.pprint-pop+ object xp) xp))))
  1681.  
  1682. (define (xp.cond-print object xp)
  1683.   ;; (formatter "~:<~W~^ ~:I~@_~@{~:/xp:pprint-linear/~^ ~_~}~:>")
  1684.   (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
  1685.     (xp.write+ (xp.pprint-pop+ object xp) xp)
  1686.     (xp.pprint-exit-if-list-exhausted+ object)
  1687.     (xp.write-char++ #\space xp)
  1688.     (xp.pprint-indent+ 'current 0 xp)
  1689.     (xp.pprint-newline+ 'miser xp)
  1690.     (pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f)
  1691.     (do ()
  1692.     ((null? object) '#f)
  1693.     (xp.write-char++ #\space xp)
  1694.     (xp.pprint-newline+ 'linear xp)
  1695.     (pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f))))
  1696.  
  1697. (define (xp.do-print object xp)
  1698.   ;; (formatter "~:<~W~^ ~:I~@_~/xp:xp.bind-list/~^ ~_~:/xp:pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>")
  1699.   (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
  1700.     (xp.write+ (xp.pprint-pop+ object xp) xp)
  1701.     (xp.pprint-exit-if-list-exhausted+ object)
  1702.     (xp.write-char++ #\space xp)
  1703.     (xp.pprint-indent+ 'current 0 xp)
  1704.     (xp.pprint-newline+ 'miser xp)
  1705.     (xp.bind-list (xp.pprint-pop+ object xp) xp '#f '#f)
  1706.     (xp.pprint-exit-if-list-exhausted+ object)
  1707.     (xp.write-char++ #\space xp)
  1708.     (xp.pprint-newline+ 'linear xp)
  1709.     (pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f)
  1710.     (xp.write-char++ #\space xp)
  1711.     (xp.pprint-indent+ 'block 1 xp)
  1712.     (do ()
  1713.     ((null? object) '#f)
  1714.     (xp.write-char++ #\space xp)
  1715.     (xp.pprint-newline+ 'linear xp)
  1716.     (xp.write+ (xp.pprint-pop+ object xp) xp))))
  1717.  
  1718. (define (xp.mvb-print object xp)
  1719.   (xp.print-fancy-fn-call object xp '(1 3 2 1)))
  1720.  
  1721. (define (xp.setf-print object xp)
  1722.   ;; (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>")
  1723.   (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
  1724.     (xp.write+ (xp.pprint-pop+ object xp) xp)
  1725.     (xp.pprint-exit-if-list-exhausted+ object)
  1726.     (xp.write-char++ #\space xp)
  1727.     (xp.pprint-indent+ 'current 0 xp)
  1728.     (xp.pprint-newline+ 'miser xp)
  1729.     (xp.write+ (xp.pprint-pop+ object xp) xp)
  1730.     (do ()
  1731.     ((null? object) '#f)
  1732.     (xp.write-char++ #\space xp)
  1733.     (xp.pprint-newline+ 'fill xp)
  1734.     (xp.write+ (xp.pprint-pop+ object xp) xp)
  1735.     (when (not (null? object))
  1736.         (xp.write-char++ #\space xp)
  1737.         (xp.pprint-newline+ 'linear xp)
  1738.         (xp.write+ (xp.pprint-pop+ object xp) xp)))))
  1739.  
  1740. (define (xp.quote-print object xp)
  1741.   (if (and (pair? (cdr object)) (null? (cddr object)))
  1742.       (begin
  1743.          (xp.write-char++ #\' xp)
  1744.      (xp.write+ (cadr object) xp))
  1745.       (pprint-fill xp object)))
  1746.  
  1747. (define (xp.up-print object xp)
  1748.   (xp.print-fancy-fn-call object xp '(0 3 1 1)))
  1749.  
  1750.  
  1751. ;;; Install printers for built-in macros and special forms into the
  1752. ;;; standard dispatch table.
  1753.  
  1754. (define-local-syntax (define-printer symbol function)
  1755.   `(setf (table-entry (dynamic *xp.pair-dispatch-table*) ',symbol)
  1756.      (function ,function)))
  1757.  
  1758.  
  1759. ;;; *** Missing support for backquote here.
  1760.  
  1761. (define-printer quote xp.quote-print)
  1762. (define-printer lambda xp.block-like)
  1763. (define-printer when xp.block-like)
  1764. (define-printer unless xp.block-like)
  1765. (define-printer cond xp.cond-print)
  1766. (define-printer case xp.block-like)
  1767. (define-printer setf xp.setf-print)
  1768. (define-printer set! xp.setf-print)
  1769. (define-printer let xp.let-print)
  1770. (define-printer let* xp.let-print)
  1771. (define-printer letrec xp.let-print)
  1772. (define-printer flet xp.flet-print)
  1773. (define-printer labels xp.flet-print)
  1774. (define-printer dynamic-let xp.let-print)
  1775. (define-printer block xp.block-like)
  1776. (define-printer do xp.do-print)
  1777. (define-printer dolist xp.block-like)
  1778. (define-printer dotimes xp.block-like)
  1779. (define-printer multiple-value-bind xp.mvb-print)
  1780. (define-printer let/cc xp.block-like)
  1781. (define-printer unwind-protect xp.up-print)
  1782. (define-printer define xp.block-like)
  1783. (define-printer define-syntax xp.block-like)
  1784. (define-printer define-local-syntax xp.block-like)
  1785. (define-printer pprint-logical-block xp.block-like)
  1786. (define-printer xp.pprint-logical-block+ xp.block-like)
  1787.  
  1788. ;;; Here are some hacks for struct macros.
  1789.  
  1790. (define-printer update-slots xp.mvb-print)
  1791. (define-printer make xp.block-like)
  1792.