source: trunk/j/src/org/armedbear/lisp/pprint.lisp @ 11297

Last change on this file since 11297 was 11297, checked in by ehuelsmann, 13 years ago

Set Id keyword for expansion.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 52.8 KB
Line 
1;;; pprint.lisp
2;;;
3;;; Copyright (C) 2004-2005 Peter Graves
4;;; $Id: pprint.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20;;; Adapted from the November, 26 1991 version of Richard C. Waters' XP pretty
21;;; printer.
22
23;------------------------------------------------------------------------
24
25;Copyright Massachusetts Institute of Technology, Cambridge, Massachusetts.
26
27;Permission to use, copy, modify, and distribute this software and its
28;documentation for any purpose and without fee is hereby granted,
29;provided that this copyright and permission notice appear in all
30;copies and supporting documentation, and that the name of M.I.T. not
31;be used in advertising or publicity pertaining to distribution of the
32;software without specific, written prior permission. M.I.T. makes no
33;representations about the suitability of this software for any
34;purpose.  It is provided "as is" without express or implied warranty.
35
36;    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
37;    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
38;    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
39;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
40;    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
41;    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
42;    SOFTWARE.
43
44;------------------------------------------------------------------------
45
46(in-package #:xp)
47
48;must do the following in common lisps not supporting *print-shared*
49
50(defvar *print-shared* nil)
51(export '(*print-shared*))
52
53(defvar *default-right-margin* 70.
54  "controls default line length; must be a non-negative integer")
55
56(defvar *current-level* 0
57  "current depth in logical blocks.")
58(defvar *abbreviation-happened* nil
59  "t if current thing being printed has been abbreviated.")
60(defvar *result* nil "used to pass back a value")
61
62;default (bad) definitions for the non-portable functions
63
64#-(or :symbolics :lucid :franz-inc :cmu)(eval-when (eval load compile)
65(defun structure-type-p (x) (and (symbolp x) (get x 'structure-printer)))
66(defun output-width     (&optional (s *standard-output*)) (declare (ignore s)) nil))
67
68(defvar *locating-circularities* nil
69  "Integer if making a first pass over things to identify circularities.
70   Integer used as counter for #n= syntax.")
71
72;               ---- XP STRUCTURES, AND THE INTERNAL ALGORITHM ----
73
74(eval-when (eval load compile) ;not used at run time.
75  (defvar block-stack-entry-size 1)
76  (defvar prefix-stack-entry-size 5)
77  (defvar queue-entry-size 7)
78  (defvar buffer-entry-size 1)
79  (defvar prefix-entry-size 1)
80  (defvar suffix-entry-size 1))
81
82(eval-when (eval load compile) ;used at run time
83  (defvar block-stack-min-size #.(* 35. block-stack-entry-size))
84  (defvar prefix-stack-min-size #.(* 30. prefix-stack-entry-size))
85  (defvar queue-min-size #.(* 75. queue-entry-size))
86  (defvar buffer-min-size 256.)
87  (defvar prefix-min-size 256.)
88  (defvar suffix-min-size 256.)
89  )
90
91(defstruct (xp-structure (:conc-name nil) #+nil (:print-function describe-xp))
92  (base-stream nil) ;;The stream io eventually goes to.
93  line-length ;;The line length to use for formatting.
94  line-limit ;;If non-NIL the max number of lines to print.
95  line-no ;;number of next line to be printed.
96  depth-in-blocks
97  ;;Number of logical blocks at QRIGHT that are started but not ended.
98  (block-stack (make-array #.block-stack-min-size)) block-stack-ptr
99  ;;This stack is pushed and popped in accordance with the way blocks are
100  ;;nested at the moment they are entered into the queue.  It contains the
101  ;;following block specific value.
102  ;;SECTION-START total position where the section (see AIM-1102)
103  ;;that is rightmost in the queue started.
104  (buffer (make-array #.buffer-min-size :element-type 'character))
105  charpos buffer-ptr buffer-offset
106  ;;This is a vector of characters (eg a string) that builds up the
107  ;;line images that will be printed out.  BUFFER-PTR is the
108  ;;buffer position where the next character should be inserted in
109  ;;the string.  CHARPOS is the output character position of the
110  ;;first character in the buffer (non-zero only if a partial line
111  ;;has been output).  BUFFER-OFFSET is used in computing total lengths.
112  ;;It is changed to reflect all shifting and insertion of prefixes so that
113  ;;total length computes things as they would be if they were
114  ;;all on one line.  Positions are kept three different ways
115  ;; Buffer position (eg BUFFER-PTR)
116  ;; Line position (eg (+ BUFFER-PTR CHARPOS)).  Indentations are stored in this form.
117  ;; Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET))
118  ;;  Positions are stored in this form.
119  (queue (make-array #.queue-min-size))
120  qleft
121  qright
122  ;;This holds a queue of action descriptors.  QLEFT and QRIGHT
123  ;;point to the next entry to dequeue and the last entry enqueued
124  ;;respectively.  The queue is empty when
125  ;;(> QLEFT QRIGHT).  The queue entries have several parts:
126  ;;QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK
127  ;;QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH
128  ;; or :BLOCK/:CURRENT
129  ;;QPOS total position corresponding to this entry
130  ;;QDEPTH depth in blocks of this entry.
131  ;;QEND offset to entry marking end of section this entry starts. (NIL until known.)
132  ;; Only :start-block and non-literal :newline entries can start sections.
133  ;;QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known).
134  ;;QARG for :IND indentation delta
135  ;;     for :START-BLOCK suffix in the block if any.
136  ;;                      or if per-line-prefix then cons of suffix and
137  ;;                      per-line-prefix.
138  ;;     for :END-BLOCK suffix for the block if any.
139  (prefix (make-array #.buffer-min-size :element-type 'character))
140  ;;this stores the prefix that should be used at the start of the line
141  (prefix-stack (make-array #.prefix-stack-min-size))
142  prefix-stack-ptr
143  ;;This stack is pushed and popped in accordance with the way blocks
144  ;;are nested at the moment things are taken off the queue and printed.
145  ;;It contains the following block specific values.
146  ;;PREFIX-PTR current length of PREFIX.
147  ;;SUFFIX-PTR current length of pending suffix
148  ;;NON-BLANK-PREFIX-PTR current length of non-blank prefix.
149  ;;INITIAL-PREFIX-PTR prefix-ptr at the start of this block.
150  ;;SECTION-START-LINE line-no value at last non-literal break at this level.
151  (suffix (make-array #.buffer-min-size :element-type 'character))
152  ;;this stores the suffixes that have to be printed to close of the current
153  ;;open blocks.  For convenient in popping, the whole suffix
154  ;;is stored in reverse order.
155)
156
157
158(defun ext:charpos (stream)
159  (cond ((xp-structure-p stream)
160         (charpos stream))
161        ((streamp stream)
162         (sys::stream-charpos stream))))
163
164(defun (setf ext:charpos) (new-value stream)
165  (cond ((xp-structure-p stream)
166         (setf (charpos stream) new-value))
167        ((streamp stream)
168         (sys::stream-%set-charpos stream new-value))))
169
170
171(defmacro LP<-BP (xp &optional (ptr nil))
172  (if (null ptr) (setq ptr `(buffer-ptr ,xp)))
173  `(+ ,ptr (charpos ,xp)))
174(defmacro TP<-BP (xp)
175  `(+ (buffer-ptr ,xp) (buffer-offset ,xp)))
176(defmacro BP<-LP (xp ptr)
177  `(- ,ptr (charpos ,xp)))
178(defmacro BP<-TP (xp ptr)
179  `(- ,ptr (buffer-offset ,xp)))
180;This does not tell you the line position you were at when the TP
181;was set, unless there have been no newlines or indentation output
182;between ptr and the current output point.
183(defmacro LP<-TP (xp ptr)
184  `(LP<-BP ,xp (BP<-TP ,xp ,ptr)))
185
186;We don't use adjustable vectors or any of that, because we seldom have
187;to actually extend and non-adjustable vectors are a lot faster in
188;many Common Lisps.
189
190(defmacro check-size (xp vect ptr)
191  (let* ((min-size
192     (symbol-value
193       (intern (concatenate 'string (string vect) "-MIN-SIZE")
194         (find-package "XP"))))
195   (entry-size
196     (symbol-value
197       (intern (concatenate 'string (string vect) "-ENTRY-SIZE")
198         (find-package "XP")))))
199    `(when (and (> ,ptr ,(- min-size entry-size)) ;seldom happens
200    (> ,ptr (- (length (,vect ,xp)) ,entry-size)))
201       (let* ((old (,vect ,xp))
202        (new (make-array (+ ,ptr ,(if (= entry-size 1) 50
203              (* 10 entry-size)))
204             :element-type (array-element-type old))))
205   (replace new old)
206   (setf (,vect ,xp) new)))))
207
208(defmacro section-start (xp) `(aref (block-stack ,xp) (block-stack-ptr ,xp)))
209
210(defun push-block-stack (xp)
211  (incf (block-stack-ptr xp) #.block-stack-entry-size)
212  (check-size xp block-stack (block-stack-ptr xp)))
213
214(defun pop-block-stack (xp)
215  (decf (block-stack-ptr xp) #.block-stack-entry-size))
216
217(defmacro prefix-ptr (xp)
218  `(aref (prefix-stack ,xp) (prefix-stack-ptr ,xp)))
219(defmacro suffix-ptr (xp)
220  `(aref (prefix-stack ,xp) (+ (prefix-stack-ptr ,xp) 1)))
221(defmacro non-blank-prefix-ptr (xp)
222  `(aref (prefix-stack ,xp) (+ (prefix-stack-ptr ,xp) 2)))
223(defmacro initial-prefix-ptr (xp)
224  `(aref (prefix-stack ,xp) (+ (prefix-stack-ptr ,xp) 3)))
225(defmacro section-start-line (xp)
226  `(aref (prefix-stack ,xp) (+ (prefix-stack-ptr ,xp) 4)))
227
228(defun push-prefix-stack (xp)
229  (let ((old-prefix 0)
230        (old-suffix 0)
231        (old-non-blank 0))
232    (when (not (minusp (prefix-stack-ptr xp)))
233      (setq old-prefix (prefix-ptr xp)
234      old-suffix (suffix-ptr xp)
235      old-non-blank (non-blank-prefix-ptr xp)))
236    (incf (prefix-stack-ptr xp) #.prefix-stack-entry-size)
237    (check-size xp prefix-stack (prefix-stack-ptr xp))
238    (setf (prefix-ptr xp) old-prefix)
239    (setf (suffix-ptr xp) old-suffix)
240    (setf (non-blank-prefix-ptr xp) old-non-blank)))
241
242(defun pop-prefix-stack (xp)
243  (decf (prefix-stack-ptr xp) #.prefix-stack-entry-size))
244
245(defmacro Qtype   (xp index) `(aref (queue ,xp) ,index))
246(defmacro Qkind   (xp index) `(aref (queue ,xp) (1+ ,index)))
247(defmacro Qpos    (xp index) `(aref (queue ,xp) (+ ,index 2)))
248(defmacro Qdepth  (xp index) `(aref (queue ,xp) (+ ,index 3)))
249(defmacro Qend    (xp index) `(aref (queue ,xp) (+ ,index 4)))
250(defmacro Qoffset (xp index) `(aref (queue ,xp) (+ ,index 5)))
251(defmacro Qarg    (xp index) `(aref (queue ,xp) (+ ,index 6)))
252
253;we shift the queue over rather than using a circular queue because
254;that works out to be a lot faster in practice.  Note, short printout
255;does not ever cause a shift, and even in long printout, the queue is
256;shifted left for free every time it happens to empty out.
257
258(defun enqueue (xp type kind &optional arg)
259  (incf (Qright xp) #.queue-entry-size)
260  (when (> (Qright xp) #.(- queue-min-size queue-entry-size))
261    (replace (queue xp) (queue xp) :start2 (Qleft xp) :end2 (Qright xp))
262    (setf (Qright xp) (- (Qright xp) (Qleft xp)))
263    (setf (Qleft xp) 0))
264  (check-size xp queue (Qright xp))
265  (setf (Qtype xp (Qright xp)) type)
266  (setf (Qkind xp (Qright xp)) kind)
267  (setf (Qpos xp (Qright xp)) (TP<-BP xp))
268  (setf (Qdepth xp (Qright xp)) (depth-in-blocks xp))
269  (setf (Qend xp (Qright xp)) nil)
270  (setf (Qoffset xp (Qright xp)) nil)
271  (setf (Qarg xp (Qright xp)) arg))
272
273(defmacro Qnext (index) `(+ ,index #.queue-entry-size))
274
275;This is called to initialize things when you start pretty printing.
276
277(defun initialize-xp (xp stream)
278  (setf (base-stream xp) stream)
279  (setf (line-length xp) (max 0 (cond (*print-right-margin*)
280                                      ((output-width stream))
281                                      (t *default-right-margin*))))
282  (setf (line-limit xp) *print-lines*)
283  (setf (line-no xp) 1)
284  (setf (depth-in-blocks xp) 0)
285  (setf (block-stack-ptr xp) 0)
286  (setf (charpos xp) (cond ((ext:charpos stream)) (t 0)))
287  (setf (section-start xp) 0)
288  (setf (buffer-ptr xp) 0)
289  (setf (buffer-offset xp) (charpos xp))
290  (setf (Qleft xp) 0)
291  (setf (Qright xp) #.(- queue-entry-size))
292  (setf (prefix-stack-ptr xp) #.(- prefix-stack-entry-size))
293  xp)
294
295;This handles the basic outputting of characters.  note + suffix means that
296;the stream is known to be an XP stream, all inputs are mandatory, and no
297;error checking has to be done.  Suffix ++ additionally means that the
298;output is guaranteed not to contain a newline char.
299
300(defun write-char+ (char xp)
301  (if (eql char #\newline) (pprint-newline+ :unconditional xp)
302      (write-char++ char xp)))
303
304(defun write-string+ (string xp start end)
305  (let ((sub-end nil) next-newline)
306    (loop (setq next-newline
307    (position #\newline string :test #'char= :start start :end end))
308    (setq sub-end (if next-newline next-newline end))
309    (write-string++ string xp start sub-end)
310    (when (null next-newline) (return nil))
311    (pprint-newline+ :unconditional xp)
312    (setq start (1+ sub-end)))))
313
314;note this checks (> BUFFER-PTR LINE-LENGTH) instead of (> (LP<-BP) LINE-LENGTH)
315;this is important so that when things are longer than a line they
316;end up getting printed in chunks of size LINE-LENGTH.
317
318(defun write-char++ (char xp)
319  (when (> (buffer-ptr xp) (line-length xp))
320    (force-some-output xp))
321  (let ((new-buffer-end (1+ (buffer-ptr xp))))
322    (check-size xp buffer new-buffer-end)
323    (setf (char (buffer xp) (buffer-ptr xp)) char)
324    (setf (buffer-ptr xp) new-buffer-end)))
325
326(defun force-some-output (xp)
327  (attempt-to-output xp nil nil)
328  (when (> (buffer-ptr xp) (line-length xp)) ;only if printing off end of line
329    (attempt-to-output xp T T)))
330
331(defun write-string++ (string xp start end)
332  (when (> (buffer-ptr xp) (line-length xp))
333    (force-some-output xp))
334  (write-string+++ string xp start end))
335
336;never forces output; therefore safe to call from within output-line.
337
338(defun write-string+++ (string xp start end)
339  (let ((new-buffer-end (+ (buffer-ptr xp) (- end start))))
340    (check-size xp buffer new-buffer-end)
341    (do ((buffer (buffer xp))
342   (i (buffer-ptr xp) (1+ i))
343   (j start (1+ j)))
344  ((= j end))
345      (let ((char (char string j)))
346  (setf (char buffer i) char)))
347    (setf (buffer-ptr xp) new-buffer-end)))
348
349(defun pprint-tab+ (kind colnum colinc xp)
350  (let ((indented? nil) (relative? nil))
351    (case kind
352      (:section (setq indented? t))
353      (:line-relative (setq relative? t))
354      (:section-relative (setq indented? t relative? t)))
355    (let* ((current
356       (if (not indented?) (LP<-BP xp)
357     (- (TP<-BP xp) (section-start xp))))
358     (new
359       (if (zerop colinc)
360     (if relative? (+ current colnum) (max colnum current))
361     (cond (relative?
362      (* colinc (floor (+ current colnum colinc -1) colinc)))
363           ((> colnum current) colnum)
364           (T (+ colnum
365           (* colinc
366        (floor (+ current (- colnum) colinc) colinc)))))))
367     (length (- new current)))
368      (when (plusp length)
369  (let ((end (+ (buffer-ptr xp) length)))
370    (check-size xp buffer end)
371    (fill (buffer xp) #\space :start (buffer-ptr xp) :end end)
372    (setf (buffer-ptr xp) end))))))
373
374;note following is smallest number >= x that is a multiple of colinc
375;  (* colinc (floor (+ x (1- colinc)) colinc))
376
377(defun pprint-newline+ (kind xp)
378  (enqueue xp :newline kind)
379  (do ((ptr (Qleft xp) (Qnext ptr)))    ;find sections we are ending
380      ((not (< ptr (Qright xp)))) ;all but last
381    (when (and (null (Qend xp ptr))
382         (not (> (depth-in-blocks xp) (Qdepth xp ptr)))
383         (member (Qtype xp ptr) '(:newline :start-block)))
384      (setf (Qend xp ptr) (- (Qright xp) ptr))))
385  (setf (section-start xp) (TP<-BP xp))
386  (when (member kind '(:fresh :unconditional :mandatory))
387    (attempt-to-output xp T nil)))
388
389(defun start-block (xp prefix on-each-line? suffix)
390  (unless (stringp prefix)
391    (error 'type-error
392     :datum prefix
393     :expected-type 'string))
394  (unless (stringp suffix)
395    (error 'type-error
396     :datum suffix
397     :expected-type 'string))
398  (when prefix
399    (write-string++ prefix xp 0 (length prefix)))
400  (push-block-stack xp)
401  (enqueue xp :start-block nil
402     (if on-each-line? (cons suffix prefix) suffix))
403  (incf (depth-in-blocks xp))       ;must be after enqueue
404  (setf (section-start xp) (TP<-BP xp)))
405
406(defun end-block (xp suffix)
407  (unless (eq *abbreviation-happened* '*print-lines*)
408    (when suffix
409      (write-string+ suffix xp 0 (length suffix)))
410    (decf (depth-in-blocks xp))
411    (enqueue xp :end-block nil suffix)
412    (do ((ptr (Qleft xp) (Qnext ptr))) ;looking for start of block we are ending
413  ((not (< ptr (Qright xp))))    ;all but last
414      (when (and (= (depth-in-blocks xp) (Qdepth xp ptr))
415     (eq (Qtype xp ptr) :start-block)
416     (null (Qoffset xp ptr)))
417  (setf (Qoffset xp ptr) (- (Qright xp) ptr))
418  (return nil)))  ;can only be 1
419    (pop-block-stack xp)))
420
421(defun pprint-indent+ (kind n xp)
422  (enqueue xp :ind kind n))
423
424; The next function scans the queue looking for things it can do.
425;it keeps outputting things until the queue is empty, or it finds
426;a place where it cannot make a decision yet.
427
428(defmacro maybe-too-large (xp Qentry)
429  `(let ((limit (line-length ,xp)))
430     (when (eql (line-limit ,xp) (line-no ,xp)) ;prevents suffix overflow
431       (decf limit 2) ;3 for " .." minus 1 for space (heuristic)
432       (when (not (minusp (prefix-stack-ptr ,xp)))
433   (decf limit (suffix-ptr ,xp))))
434     (cond ((Qend ,xp ,Qentry)
435      (> (LP<-TP ,xp (Qpos ,xp (+ ,Qentry (Qend ,xp ,Qentry)))) limit))
436     ((or force-newlines? (> (LP<-BP ,xp) limit)) T)
437     (T (return nil)))))  ;wait until later to decide.
438
439(defmacro misering? (xp)
440  `(and *print-miser-width*
441  (<= (- (line-length ,xp) (initial-prefix-ptr ,xp)) *print-miser-width*)))
442
443;If flush-out? is T and force-newlines? is NIL then the buffer,
444;prefix-stack, and queue will be in an inconsistent state after the call.
445;You better not call it this way except as the last act of outputting.
446
447(defun attempt-to-output (xp force-newlines? flush-out?)
448  (do () ((> (Qleft xp) (Qright xp))
449    (setf (Qleft xp) 0)
450    (setf (Qright xp) #.(- queue-entry-size))) ;saves shifting
451    (case (Qtype xp (Qleft xp))
452      (:ind
453       (unless (misering? xp)
454   (set-indentation-prefix xp
455     (case (Qkind xp (Qleft xp))
456       (:block (+ (initial-prefix-ptr xp) (Qarg xp (Qleft xp))))
457       (T ; :current
458         (+ (LP<-TP xp (Qpos xp (Qleft xp)))
459      (Qarg xp (Qleft xp)))))))
460       (setf (Qleft xp) (Qnext (Qleft xp))))
461      (:start-block
462       (cond ((maybe-too-large xp (Qleft xp))
463        (push-prefix-stack xp)
464        (setf (initial-prefix-ptr xp) (prefix-ptr xp))
465        (set-indentation-prefix xp (LP<-TP xp (Qpos xp (Qleft xp))))
466        (let ((arg (Qarg xp (Qleft xp))))
467    (when (consp arg) (set-prefix xp (cdr arg)))
468    (setf (initial-prefix-ptr xp) (prefix-ptr xp))
469    (cond ((not (listp arg)) (set-suffix xp arg))
470          ((car arg) (set-suffix xp (car arg)))))
471        (setf (section-start-line xp) (line-no xp)))
472       (T (incf (Qleft xp) (Qoffset xp (Qleft xp)))))
473       (setf (Qleft xp) (Qnext (Qleft xp))))
474      (:end-block (pop-prefix-stack xp) (setf (Qleft xp) (Qnext (Qleft xp))))
475      (T ; :newline
476       (when (case (Qkind xp (Qleft xp))
477         (:fresh (not (zerop (LP<-BP xp))))
478         (:miser (misering? xp))
479         (:fill (or (misering? xp)
480        (> (line-no xp) (section-start-line xp))
481        (maybe-too-large xp (Qleft xp))))
482         (T T)) ;(:linear :unconditional :mandatory)
483   (output-line xp (Qleft xp))
484   (setup-for-next-line xp (Qleft xp)))
485       (setf (Qleft xp) (Qnext (Qleft xp))))))
486  (when flush-out? (flush xp)))
487
488;this can only be called last!
489
490(defun flush (xp)
491  (unless *locating-circularities*
492    (write-string (buffer xp) (base-stream xp) :end (buffer-ptr xp)))
493  (incf (buffer-offset xp) (buffer-ptr xp))
494  (incf (charpos xp) (buffer-ptr xp))
495  (setf (buffer-ptr xp) 0))
496
497;This prints out a line of stuff.
498
499(defun output-line (xp Qentry)
500  (let* ((out-point (BP<-TP xp (Qpos xp Qentry)))
501   (last-non-blank (position #\space (buffer xp) :test-not #'char=
502           :from-end T :end out-point))
503   (end (cond ((member (Qkind xp Qentry) '(:fresh :unconditional)) out-point)
504        (last-non-blank (1+ last-non-blank))
505        (T 0)))
506   (line-limit-exit (and (line-limit xp)
507                               (not *print-readably*)
508                               (not (> (line-limit xp) (line-no xp))))))
509    (when line-limit-exit
510      (setf (buffer-ptr xp) end)          ;truncate pending output.
511      (write-string+++ " .." xp 0 3)
512      (reverse-string-in-place (suffix xp) 0 (suffix-ptr xp))
513      (write-string+++ (suffix xp) xp 0 (suffix-ptr xp))
514      (setf (Qleft xp) (Qnext (Qright xp)))
515      (setf *abbreviation-happened* '*print-lines*)
516      (throw 'line-limit-abbreviation-exit T))
517    (incf (line-no xp))
518    (unless *locating-circularities*
519      (let ((stream (base-stream xp)))
520  (sys::%write-string (buffer xp) stream 0 end)
521  (sys::%terpri stream)))))
522
523(defun setup-for-next-line (xp Qentry)
524  (let* ((out-point (BP<-TP xp (Qpos xp Qentry)))
525   (prefix-end
526     (cond ((member (Qkind xp Qentry) '(:unconditional :fresh))
527      (non-blank-prefix-ptr xp))
528     (T (prefix-ptr xp))))
529   (change (- prefix-end out-point)))
530    (setf (charpos xp) 0)
531    (when (plusp change)                  ;almost never happens
532      (check-size xp buffer (+ (buffer-ptr xp) change)))
533    (replace (buffer xp) (buffer xp) :start1 prefix-end
534       :start2 out-point :end2 (buffer-ptr xp))
535    (replace (buffer xp) (prefix xp) :end2 prefix-end)
536    (incf (buffer-ptr xp) change)
537    (decf (buffer-offset xp) change)
538    (when (not (member (Qkind xp Qentry) '(:unconditional :fresh)))
539      (setf (section-start-line xp) (line-no xp)))))
540
541(defun set-indentation-prefix (xp new-position)
542  (let ((new-ind (max (non-blank-prefix-ptr xp) new-position)))
543    (setf (prefix-ptr xp) (initial-prefix-ptr xp))
544    (check-size xp prefix new-ind)
545    (when (> new-ind (prefix-ptr xp))
546      (fill (prefix xp) #\space :start (prefix-ptr xp) :end new-ind))
547    (setf (prefix-ptr xp) new-ind)))
548
549(defun set-prefix (xp prefix-string)
550  (replace (prefix xp) prefix-string
551     :start1 (- (prefix-ptr xp) (length prefix-string)))
552  (setf (non-blank-prefix-ptr xp) (prefix-ptr xp)))
553
554(defun set-suffix (xp suffix-string)
555  (let* ((end (length suffix-string))
556   (new-end (+ (suffix-ptr xp) end)))
557    (check-size xp suffix new-end)
558    (do ((i (1- new-end) (1- i)) (j 0 (1+ j))) ((= j end))
559      (setf (char (suffix xp) i) (char suffix-string j)))
560    (setf (suffix-ptr xp) new-end)))
561
562(defun reverse-string-in-place (string start end)
563  (do ((i start (1+ i)) (j (1- end) (1- j))) ((not (< i j)) string)
564    (let ((c (char string i)))
565      (setf (char string i) (char string j))
566      (setf (char string j) c))))
567
568;      ---- BASIC INTERFACE FUNCTIONS ----
569
570;The internal functions in this file, and the (formatter "...") expansions
571;use the '+' forms of these functions directly (which is faster) because,
572;they do not need error checking of fancy stream coercion.  The '++' forms
573;additionally assume the thing being output does not contain a newline.
574
575(defun write (object &key
576         ((:stream stream) *standard-output*)
577         ((:escape *print-escape*) *print-escape*)
578         ((:radix *print-radix*) *print-radix*)
579         ((:base *print-base*) *print-base*)
580         ((:circle *print-circle*) *print-circle*)
581         ((:pretty *print-pretty*) *print-pretty*)
582         ((:level *print-level*) *print-level*)
583         ((:length *print-length*) *print-length*)
584         ((:case *print-case*) *print-case*)
585         ((:array *print-array*) *print-array*)
586         ((:gensym *print-gensym*) *print-gensym*)
587         ((:readably *print-readably*) *print-readably*)
588         ((:right-margin *print-right-margin*)
589          *print-right-margin*)
590         ((:miser-width *print-miser-width*)
591          *print-miser-width*)
592         ((:lines *print-lines*) *print-lines*)
593         ((:pprint-dispatch *print-pprint-dispatch*)
594          *print-pprint-dispatch*))
595  (sys:output-object object (sys:out-synonym-of stream))
596  object)
597
598(defun maybe-initiate-xp-printing (fn stream &rest args)
599  (if (xp-structure-p stream)
600      (apply fn stream args)
601      (let ((*abbreviation-happened* nil)
602      (sys::*circularity-hash-table*
603             (if (and *print-circle* (null sys::*circularity-hash-table*))
604                 (make-hash-table :test 'eq)
605                 sys::*circularity-hash-table*))
606      (*result* nil))
607  (xp-print fn (sys:out-synonym-of stream) args)
608  *result*)))
609
610(defun xp-print (fn stream args)
611  (setq *result* (do-xp-printing fn stream args))
612  (when *locating-circularities*
613    (setq *locating-circularities* nil)
614    (setq *abbreviation-happened* nil)
615;;     (setq *parents* nil)
616    (setq *result* (do-xp-printing fn stream args))))
617
618(defun do-xp-printing (fn stream args)
619  (let ((xp (initialize-xp (make-xp-structure) stream))
620  (*current-level* 0)
621  (result nil))
622    (catch 'line-limit-abbreviation-exit
623      (start-block xp "" nil "")
624      (setq result (apply fn xp args))
625      (end-block xp nil))
626    (when (and *locating-circularities*
627         (zerop *locating-circularities*) ;No circularities.
628         (= (line-no xp) 1)       ;Didn't suppress line.
629         (zerop (buffer-offset xp)))  ;Didn't suppress partial line.
630      (setq *locating-circularities* nil))  ;print what you have got.
631    (when (catch 'line-limit-abbreviation-exit
632      (attempt-to-output xp nil t) nil)
633      (attempt-to-output xp t t))
634    result))
635
636(defun write+ (object xp)
637;;   (let ((*parents* *parents*))
638;;     (unless (and *circularity-hash-table*
639;;                  (eq (circularity-process xp object nil) :subsequent))
640;;       (when (and *circularity-hash-table* (consp object))
641;;  ;;avoid possible double check in handle-logical-block.
642;;  (setq object (cons (car object) (cdr object))))
643  (let ((printer (if *print-pretty* (get-printer object *print-pprint-dispatch*) nil))
644        type)
645    (cond (printer (funcall printer xp object))
646          ((maybe-print-fast object xp))
647          ((and *print-pretty*
648                (symbolp (setq type (type-of object)))
649                (setq printer (get type 'structure-printer))
650                (not (eq printer :none)))
651           (funcall printer xp object))
652          ((and *print-pretty* *print-array* (arrayp object)
653                (not (stringp object)) (not (bit-vector-p object))
654                (not (structure-type-p (type-of object))))
655           (pretty-array xp object))
656          (t
657           (let ((stuff (with-output-to-string (s) (non-pretty-print object s))))
658             (write-string+ stuff xp 0 (length stuff)))))))
659
660(defun non-pretty-print (object s)
661;;   (write object
662;;          :level (if *print-level*
663;;                     (- *print-level* *current-level*))
664;;          :pretty nil
665;;          :stream s))
666  (sys::output-ugly-object object s))
667
668;This prints a few very common, simple atoms very fast.
669;Pragmatically, this turns out to be an enormous savings over going to the
670;standard printer all the time.  There would be diminishing returns from making
671;this work with more things, but might be worth it.
672(defun maybe-print-fast (object xp)
673  (cond ((stringp object)
674         (let ((s (sys::%write-to-string object)))
675           (write-string++ s xp 0 (length s))
676           t))
677  ((ext:fixnump object)
678         (print-fixnum xp object)
679         t)
680  ((and (symbolp object)
681              (or (symbol-package object)
682                  (null *print-circle*)))
683         (let ((s (sys::%write-to-string object)))
684           (write-string++ s xp 0 (length s))
685           t)
686         )))
687
688(defun print-fixnum (xp fixnum)
689  (let ((s (sys::%write-to-string fixnum)))
690    (write-string++ s xp 0 (length s))))
691
692(defun print (object &optional (stream *standard-output*))
693  (setf stream (sys:out-synonym-of stream))
694  (terpri stream)
695  (let ((*print-escape* t))
696    (sys:output-object object stream))
697  (write-char #\space stream)
698  object)
699
700(defun prin1 (object &optional (stream *standard-output*))
701  (let ((*print-escape* t))
702    (sys:output-object object (sys:out-synonym-of stream)))
703  object)
704
705(defun princ (object &optional (stream *standard-output*))
706  (let ((*print-escape* nil)
707        (*print-readably* nil))
708    (sys:output-object object (sys:out-synonym-of stream)))
709  object)
710
711(defun pprint (object &optional (stream *standard-output*))
712  (setq stream (sys:out-synonym-of stream))
713  (terpri stream)
714  (let ((*print-escape* T) (*print-pretty* T))
715    (sys:output-object object stream))
716  (values))
717
718(defun write-to-string (object &key
719                               ((:escape *print-escape*) *print-escape*)
720                               ((:radix *print-radix*) *print-radix*)
721                               ((:base *print-base*) *print-base*)
722                               ((:circle *print-circle*) *print-circle*)
723                               ((:pretty *print-pretty*) *print-pretty*)
724                               ((:level *print-level*) *print-level*)
725                               ((:length *print-length*) *print-length*)
726                               ((:case *print-case*) *print-case*)
727                               ((:array *print-array*) *print-array*)
728                               ((:gensym *print-gensym*) *print-gensym*)
729                               ((:readably *print-readably*) *print-readably*)
730                               ((:right-margin *print-right-margin*) *print-right-margin*)
731                               ((:miser-width *print-miser-width*) *print-miser-width*)
732                               ((:lines *print-lines*) *print-lines*)
733                               ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*))
734  (let ((stream (make-string-output-stream)))
735    (sys:output-object object stream)
736    (get-output-stream-string stream)))
737
738(defun prin1-to-string (object)
739  (with-output-to-string (stream)
740    (let ((*print-escape* t))
741      (sys:output-object object stream))))
742
743(defun princ-to-string (object)
744  (with-output-to-string (stream)
745    (let ((*print-escape* nil)
746          (*print-readably* nil))
747      (sys:output-object object stream))))
748
749(defun write-char (char &optional (stream *standard-output*))
750  (setf stream (sys:out-synonym-of stream))
751  (if (xp-structure-p stream)
752      (write-char+ char stream)
753      (sys:%stream-write-char char stream))
754  char)
755
756(defun write-string (string &optional (stream *standard-output*)
757                            &key (start 0) (end (length string)))
758  (setf stream (sys:out-synonym-of stream))
759  (if (xp-structure-p stream)
760      (write-string+ string stream start end)
761      (progn
762        (unless start
763          (setf start 0))
764        (if end
765            (setf end (min end (length string)))
766            (setf end (length string)))
767        (sys::%write-string string stream start end)))
768  string)
769
770(defun write-line (string &optional (stream *standard-output*)
771       &key (start 0) (end (length string)))
772  (setf stream (sys:out-synonym-of stream))
773  (cond ((xp-structure-p stream)
774         (write-string+ string stream start end)
775         (pprint-newline+ :unconditional stream))
776        (t (sys::%write-string string stream start end)
777           (sys::%terpri stream)))
778  string)
779
780(defun terpri (&optional (stream *standard-output*))
781  (setf stream (sys:out-synonym-of stream))
782  (if (xp-structure-p stream)
783      (pprint-newline+ :unconditional stream)
784      (sys:%stream-terpri stream))
785  nil)
786
787;This has to violate the XP data abstraction and fool with internal
788;stuff, in order to find out the right info to return as the result.
789
790(defun fresh-line (&optional (stream *standard-output*))
791  (setf stream (sys:out-synonym-of stream))
792  (cond ((xp-structure-p stream)
793   (attempt-to-output stream t t) ;ok because we want newline
794   (when (not (zerop (LP<-BP stream)))
795     (pprint-newline+ :fresh stream)
796     t))
797  (t
798         (sys::%fresh-line stream))))
799
800;Each of these causes the stream to be pessimistic and insert
801;newlines wherever it might have to, when forcing the partial output
802;out.  This is so that things will be in a consistent state if
803;output continues to the stream later.
804
805(defun finish-output (&optional (stream *standard-output*))
806  (setf stream (sys:out-synonym-of stream))
807  (when (xp-structure-p stream)
808    (attempt-to-output stream T T)
809    (setf stream (base-stream stream)))
810  (sys::%finish-output stream)
811  nil)
812
813(defun force-output (&optional (stream *standard-output*))
814  (setf stream (sys:out-synonym-of stream))
815  (when (xp-structure-p stream)
816    (attempt-to-output stream T T)
817    (setf stream (base-stream stream)))
818  (sys::%force-output stream)
819  nil)
820
821(defun clear-output (&optional (stream *standard-output*))
822  (setf stream (sys:out-synonym-of stream))
823  (when (xp-structure-p stream)
824    (let ((*locating-circularities* 0)) ;hack to prevent visible output
825      (attempt-to-output stream T T)
826      (setf stream (base-stream stream))))
827  (sys::%clear-output stream)
828  nil)
829
830;The internal functions in this file, and the (formatter "...") expansions
831;use the '+' forms of these functions directly (which is faster) because,
832;they do not need error checking or fancy stream coercion.  The '++' forms
833;additionally assume the thing being output does not contain a newline.
834
835(defmacro pprint-logical-block ((stream-symbol object
836                                               &key
837                                               (prefix "" prefix-p)
838                                               (per-line-prefix "" per-line-prefix-p)
839                                               (suffix ""))
840        &body body)
841  (cond ((eq stream-symbol nil)
842         (setf stream-symbol '*standard-output*))
843  ((eq stream-symbol t)
844         (setf stream-symbol '*terminal-io*)))
845  (unless (symbolp stream-symbol)
846    (warn "STREAM-SYMBOL arg ~S to PPRINT-LOGICAL-BLOCK is not a bindable symbol."
847    stream-symbol)
848    (setf stream-symbol '*standard-output*))
849  (when (and prefix-p per-line-prefix-p)
850    (error "Cannot specify values for both PREFIX and PER-LINE-PREFIX."))
851  `(maybe-initiate-xp-printing
852     #'(lambda (,stream-symbol)
853   (let ((+l ,object)
854               (+p ,(cond (prefix-p prefix)
855                          (per-line-prefix-p per-line-prefix)
856                          (t "")))
857         (+s ,suffix))
858     (pprint-logical-block+
859       (,stream-symbol +l +p +s ,per-line-prefix-p t nil)
860       ,@ body nil)))
861     (sys:out-synonym-of ,stream-symbol)))
862
863;Assumes var and args must be variables.  Other arguments must be literals or variables.
864
865(defmacro pprint-logical-block+ ((var args prefix suffix per-line? circle-check? atsign?)
866         &body body)
867;;    (when (and circle-check? atsign?)
868;;      (setf circle-check? 'not-first-p))
869  (declare (ignore atsign?))
870  `(let ((*current-level* (1+ *current-level*))
871   (sys:*current-print-length* -1)
872;;   ,@(if (and circle-check? atsign?)
873;;                `((not-first-p (plusp sys:*current-print-length*))))
874         )
875     (unless (check-block-abbreviation ,var ,args ,circle-check?)
876       (block logical-block
877   (start-block ,var ,prefix ,per-line? ,suffix)
878   (unwind-protect
879     (macrolet ((pprint-pop () `(pprint-pop+ ,',args ,',var))
880          (pprint-exit-if-list-exhausted ()
881      `(if (null ,',args) (return-from logical-block nil))))
882       ,@ body)
883     (end-block ,var ,suffix))))))
884
885;; "If stream is a pretty printing stream and the value of *PRINT-PRETTY* is
886;; true, a line break is inserted in the output when the appropriate condition
887;; below is satisfied; otherwise, PPRINT-NEWLINE has no effect."
888(defun pprint-newline (kind &optional (stream *standard-output*))
889  (sys:require-type kind '(MEMBER :LINEAR :MISER :FILL :MANDATORY))
890  (setq stream (sys:out-synonym-of stream))
891  (when (not (member kind '(:linear :miser :fill :mandatory)))
892    (error 'simple-type-error
893           :format-control "Invalid KIND argument ~A to PPRINT-NEWLINE."
894           :format-arguments (list kind)))
895  (when (and (xp-structure-p stream) *print-pretty*)
896    (pprint-newline+ kind stream))
897  nil)
898
899;; "If stream is a pretty printing stream and the value of *PRINT-PRETTY* is
900;; true, PPRINT-INDENT sets the indentation in the innermost dynamically
901;; enclosing logical block; otherwise, PPRINT-INDENT has no effect."
902(defun pprint-indent (relative-to n &optional (stream *standard-output*))
903  (setq stream (sys:out-synonym-of stream))
904  (when (not (member relative-to '(:block :current)))
905    (error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to))
906  (when (and (xp-structure-p stream) *print-pretty*)
907    (pprint-indent+ relative-to (truncate n) stream))
908  nil)
909
910(defun pprint-tab (kind colnum colinc &optional (stream *standard-output*))
911  (setq stream (sys:out-synonym-of stream))
912  (when (not (member kind '(:line :section :line-relative :section-relative)))
913    (error "Invalid KIND argument ~A to PPRINT-TAB" kind))
914  (when (and (xp-structure-p stream) *print-pretty*)
915    (pprint-tab+ kind colnum colinc stream))
916  nil)
917
918(eval-when (:compile-toplevel :load-toplevel :execute)
919  (defmacro pprint-pop+ (args xp)
920    `(if (pprint-pop-check+ ,args ,xp)
921         (return-from logical-block nil)
922         (pop ,args)))
923
924  (defun pprint-pop-check+ (args xp)
925    (incf sys:*current-print-length*)
926    (cond ((not (listp args))  ;must be first so supersedes length abbrev
927           (write-string++ ". " xp 0 2)
928           (sys:output-object args xp)
929           t)
930          ((and *print-length* ;must supersede circle check
931                (not *print-readably*)
932                (not (< sys:*current-print-length* *print-length*)))
933           (write-string++ "..." xp 0 3)
934;;            (setq *abbreviation-happened* T)
935           t)
936;;           ((and *circularity-hash-table* (not (zerop sys:*current-print-length*)))
937;;            (case (circularity-process xp args T)
938;;              (:first ;; note must inhibit rechecking of circularity for args.
939;;               (write+ (cons (car args) (cdr args)) xp) T)
940;;              (:subsequent t)
941;;              (t nil)))
942
943          ((or (not *print-circle*)
944               (sys::uniquely-identified-by-print-p args))
945           nil)
946
947          ((and (plusp sys:*current-print-length*)
948                (sys::check-for-circularity args))
949           (write-string++ ". " xp 0 2)
950           (sys:output-object args xp)
951           t)
952
953          ))
954
955  (defun check-block-abbreviation (xp args circle-check?)
956    (declare (ignore circle-check?))
957    (cond ((not (listp args))
958           (sys:output-object args xp) T)
959          ((and *print-level*
960                (not *print-readably*)
961                (> *current-level* *print-level*))
962           (write-char++ #\# xp)
963           (setf *abbreviation-happened* t)
964           t)
965;;           ((and *circularity-hash-table*
966;;                 circle-check?
967;;                 (eq (circularity-process xp args nil) :subsequent)) T)
968
969          (t
970           nil)))
971) ;; EVAL-WHEN
972
973;                ---- PRETTY PRINTING FORMATS ----
974
975(defun pretty-array (xp array)
976  (cond ((vectorp array)
977         (pretty-vector xp array))
978  ((zerop (array-rank array))
979         (when *print-readably*
980           (unless (eq (array-element-type array) t)
981             (error 'print-not-readable :object array)))
982   (write-string++ "#0A" xp 0 3)
983   (sys:output-object (aref array) xp))
984  (t
985         (pretty-non-vector xp array))))
986
987(defun pretty-vector (xp v)
988  (pprint-logical-block (xp nil :prefix "#(" :suffix ")")
989    (let ((end (length v))
990          (i 0))
991      (when (plusp end)
992  (loop
993          (pprint-pop)
994          (sys:output-object (aref v i) xp)
995          (when (= (incf i) end)
996            (return nil))
997          (write-char++ #\space xp)
998          (pprint-newline+ :fill xp))))))
999
1000(declaim (special *prefix*))
1001
1002(defun pretty-non-vector (xp array)
1003  (when (and *print-readably*
1004             (not (array-readably-printable-p array)))
1005    (error 'print-not-readable :object array))
1006  (let* ((bottom (1- (array-rank array)))
1007         (indices (make-list (1+ bottom) :initial-element 0))
1008         (dims (array-dimensions array))
1009         (*prefix* (cl:format nil "#~DA(" (1+ bottom))))
1010    (labels ((pretty-slice (slice)
1011               (pprint-logical-block (xp nil :prefix *prefix* :suffix ")")
1012                 (let ((end (nth slice dims))
1013                       (spot (nthcdr slice indices))
1014                       (i 0)
1015                       (*prefix* "("))
1016                   (when (plusp end)
1017                     (loop (pprint-pop)
1018                           (setf (car spot) i)
1019                           (if (= slice bottom)
1020                               (sys:output-object (apply #'aref array indices) xp)
1021                               (pretty-slice (1+ slice)))
1022                           (if (= (incf i) end) (return nil))
1023                           (write-char++ #\space xp)
1024                           (pprint-newline+ (if (= slice bottom) :fill :linear) xp)))))))
1025      (pretty-slice 0))))
1026
1027(defun array-readably-printable-p (array)
1028  (and (eq (array-element-type array) t)
1029       (let ((zero (position 0 (array-dimensions array)))
1030       (number (position 0 (array-dimensions array)
1031             :test (complement #'eql)
1032             :from-end t)))
1033   (or (null zero) (null number) (> zero number)))))
1034
1035;Must use pprint-logical-block (no +) in the following three, because they are
1036;exported functions.
1037
1038(defun pprint-linear (s list &optional (colon? T) atsign?)
1039  (declare (ignore atsign?))
1040  (pprint-logical-block (s list :prefix (if colon? "(" "")
1041              :suffix (if colon? ")" ""))
1042    (pprint-exit-if-list-exhausted)
1043    (loop
1044      (sys:output-object (pprint-pop) s)
1045      (pprint-exit-if-list-exhausted)
1046      (write-char++ #\space s)
1047      (pprint-newline+ :linear s))))
1048
1049(defun pprint-fill (stream object &optional (colon-p t) at-sign-p)
1050  (declare (ignore at-sign-p))
1051  (pprint-logical-block (stream object :prefix (if colon-p "(" "")
1052                                       :suffix (if colon-p ")" ""))
1053    (pprint-exit-if-list-exhausted)
1054    (loop
1055      (sys:output-object (pprint-pop) stream)
1056      (pprint-exit-if-list-exhausted)
1057      (write-char++ #\space stream)
1058      (pprint-newline+ :fill stream))))
1059
1060(defun pprint-tabular (stream list &optional (colon-p T) at-sign-p (tabsize nil))
1061  (declare (ignore at-sign-p))
1062  (when (null tabsize) (setq tabsize 16))
1063  (pprint-logical-block (stream list :prefix (if colon-p "(" "")
1064              :suffix (if colon-p ")" ""))
1065    (pprint-exit-if-list-exhausted)
1066    (loop
1067      (sys:output-object (pprint-pop) stream)
1068      (pprint-exit-if-list-exhausted)
1069      (write-char++ #\space stream)
1070      (pprint-tab+ :section-relative 0 tabsize stream)
1071      (pprint-newline+ :fill stream))))
1072
1073(defun fn-call (xp list)
1074  (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list))
1075
1076;Although idiosyncratic, I have found this very useful to avoid large
1077;indentations when printing out code.
1078
1079(defun alternative-fn-call (xp list)
1080  (if (> (length (symbol-name (car list))) 12)
1081      (funcall (formatter "~:<~1I~@{~W~^ ~_~}~:>") xp list)
1082      (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list)))
1083
1084(defun bind-list (xp list &rest args)
1085    (declare (ignore args))
1086  (if (do ((i 50 (1- i))
1087     (ls list (cdr ls))) ((null ls) t)
1088  (when (or (not (consp ls)) (not (symbolp (car ls))) (minusp i))
1089    (return nil)))
1090      (pprint-fill xp list)
1091      (funcall (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>") xp list)))
1092
1093(defun block-like (xp list &rest args)
1094  (declare (ignore args))
1095  (funcall (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>") xp list))
1096
1097(defun defun-like (xp list &rest args)
1098  (declare (ignore args))
1099  (funcall (formatter "~:<~1I~W~^ ~@_~W~^ ~@_~:/xp:pprint-fill/~^~@{ ~_~W~^~}~:>")
1100     xp list))
1101
1102(defun print-fancy-fn-call (xp list template)
1103  (let ((i 0) (in-first-section t))
1104    (pprint-logical-block+ (xp list "(" ")" nil t nil)
1105      (sys:output-object (pprint-pop) xp)
1106      (pprint-indent+ :current 1 xp)
1107      (loop
1108  (pprint-exit-if-list-exhausted)
1109  (write-char++ #\space xp)
1110  (when (eq i (car template))
1111    (pprint-indent+ :block (cadr template) xp)
1112    (setq template (cddr template))
1113    (setq in-first-section nil))
1114  (pprint-newline (cond ((and (zerop i) in-first-section) :miser)
1115            (in-first-section :fill)
1116            (T :linear))
1117      xp)
1118  (sys:output-object (pprint-pop) xp)
1119  (incf i)))))
1120
1121;This is an attempt to specify a correct format for every form in the CL book
1122;that does not just get printed out like an ordinary function call
1123;(i.e., most special forms and many macros).  This of course does not
1124;cover anything new you define.
1125
1126(defun let-print (xp obj)
1127  (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
1128           xp obj))
1129
1130(defun cond-print (xp obj)
1131  (funcall (formatter "~:<~W~^ ~:I~@_~@{~:/xp:pprint-linear/~^ ~_~}~:>") xp obj))
1132
1133(defun dmm-print (xp list)
1134  (print-fancy-fn-call xp list '(3 1)))
1135
1136(defun defsetf-print (xp list)
1137  (print-fancy-fn-call xp list '(3 1)))
1138
1139(defun do-print (xp obj)
1140  (funcall
1141   (formatter "~:<~W~^ ~:I~@_~/xp:bind-list/~^ ~_~:/xp:pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>")
1142   xp obj))
1143
1144(defun flet-print (xp obj)
1145  (funcall (formatter "~:<~1I~W~^ ~@_~:<~@{~/xp:block-like/~^ ~_~}~:>~^~@{ ~_~W~^~}~:>")
1146     xp obj))
1147
1148(defun function-print (xp list)
1149  (if (and (consp (cdr list)) (null (cddr list)))
1150      (funcall (formatter "#'~W") xp (cadr list))
1151      (fn-call xp list)))
1152
1153(defun mvb-print (xp list)
1154  (print-fancy-fn-call xp list '(1 3 2 1)))
1155
1156;; Used by PROG-PRINT and TAGBODY-PRINT.
1157(defun maybelab (xp item &rest args)
1158  (declare (ignore args) (special need-newline indentation))
1159  (when need-newline (pprint-newline+ :mandatory xp))
1160  (cond ((and item (symbolp item))
1161   (write+ item xp)
1162   (setq need-newline nil))
1163  (t (pprint-tab+ :section indentation 0 xp)
1164     (write+ item xp)
1165     (setq need-newline T))))
1166
1167(defun prog-print (xp list)
1168  (let ((need-newline T) (indentation (1+ (length (symbol-name (car list))))))
1169    (declare (special need-newline indentation))
1170    (funcall (formatter "~:<~W~^ ~:/xp:pprint-fill/~^ ~@{~/xp:maybelab/~^ ~}~:>")
1171       xp list)))
1172
1173(defun tagbody-print (xp list)
1174  (let ((need-newline (and (consp (cdr list))
1175         (symbolp (cadr list)) (cadr list)))
1176  (indentation (1+ (length (symbol-name (car list))))))
1177    (declare (special need-newline indentation))
1178    (funcall (formatter "~:<~W~^ ~@{~/xp:maybelab/~^ ~}~:>") xp list)))
1179
1180(defun setq-print (xp obj)
1181  (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>") xp obj))
1182
1183(defun quote-print (xp list)
1184  (if (and (consp (cdr list)) (null (cddr list)))
1185      (funcall (formatter "'~W") xp (cadr list))
1186      (pprint-fill xp list)))
1187
1188(defun up-print (xp list)
1189  (print-fancy-fn-call xp list '(0 3 1 1)))
1190
1191;here is some simple stuff for printing LOOP
1192
1193;The challange here is that we have to effectively parse the clauses of the
1194;loop in order to know how to print things.  Also you want to do this in a
1195;purely incremental way so that all of the abbreviation things work, and
1196;you wont blow up on circular lists or the like.  (More aesthic output could
1197;be produced by really parsing the clauses into nested lists before printing them.)
1198
1199;The following program assumes the following simplified grammar of the loop
1200;clauses that explains how to print them.  Note that it does not bare much
1201;resemblence to the right parsing grammar, however, it produces half decent
1202;output.  The way to make the output better is to make the grammar more
1203;detailed.
1204;
1205;loop == (LOOP {clause}*)      ;one clause on each line.
1206;clause == block | linear | cond | finally
1207;block == block-head {expr}*   ;as many exprs as possible on each line.
1208;linear == linear-head {expr}* ;one expr on each line.
1209;finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line.
1210;cond == cond-head [expr]
1211;          clause
1212;    {AND clause}*       ;one AND on each line.
1213;        [ELSE
1214;          clause
1215;    {AND clause}*]      ;one AND on each line.
1216;        [END]
1217;block-head == FOR | AS | WITH | AND
1218;              | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN
1219;              | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT
1220;              | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING
1221;linear-head == DO | DOING | INITIALLY
1222;var-head == FOR | AS | WITH
1223;cond-head == IF | WHEN | UNLESS
1224;expr == <anything that is not a head symbol>
1225
1226;Note all the string comparisons below are required to support some
1227;existing implementations of LOOP.
1228
1229(defun token-type (token &aux string)
1230  (cond ((not (symbolp token)) :expr)
1231  ((string= (setq string (string token)) "FINALLY") :finally)
1232  ((member string '("IF" "WHEN" "UNLESS") :test #'string=) :cond-head)
1233  ((member string '("DO" "DOING" "INITIALLY") :test #'string=) :linear-head)
1234  ((member string '("FOR" "AS" "WITH" "AND" "END" "ELSE"
1235        "REPEAT" "NAMED" "WHILE" "UNTIL" "ALWAYS" "NEVER"
1236        "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND"
1237        "APPENDING" "NCONC" "NCONCING" "COUNT" "COUNTING"
1238        "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING"
1239        "MINIMIZE" "MINIMIZING")
1240     :test #'string=)
1241   :block-head)
1242  (T :expr)))
1243
1244(defun pretty-loop (xp loop)
1245  (if (not (and (consp (cdr loop)) (symbolp (cadr loop)))) ; old-style loop
1246      (fn-call xp loop)
1247      (pprint-logical-block (xp loop :prefix "(" :suffix ")")
1248  (let (token type)
1249    (labels ((next-token ()
1250         (pprint-exit-if-list-exhausted)
1251         (setq token (pprint-pop))
1252         (setq type (token-type token)))
1253       (print-clause (xp)
1254         (case type
1255           (:linear-head (print-exprs xp nil :mandatory))
1256           (:cond-head (print-cond xp))
1257           (:finally (print-exprs xp T :mandatory))
1258           (otherwise (print-exprs xp nil :fill))))
1259       (print-exprs (xp skip-first-non-expr newline-type)
1260         (let ((first token))
1261           (next-token) ;so always happens no matter what
1262           (pprint-logical-block (xp nil)
1263       (write first :stream xp)
1264       (when (and skip-first-non-expr (not (eq type :expr)))
1265         (write-char #\space xp)
1266         (write token :stream xp)
1267         (next-token))
1268       (when (eq type :expr)
1269         (write-char #\space xp)
1270         (pprint-indent :current 0 xp)
1271         (loop (write token :stream xp)
1272         (next-token)
1273         (when (not (eq type :expr)) (return nil))
1274         (write-char #\space xp)
1275         (pprint-newline newline-type xp))))))
1276       (print-cond (xp)
1277         (let ((first token))
1278           (next-token) ;so always happens no matter what
1279           (pprint-logical-block (xp nil)
1280       (write first :stream xp)
1281       (when (eq type :expr)
1282         (write-char #\space xp)
1283         (write token :stream xp)
1284         (next-token))
1285       (write-char #\space xp)
1286       (pprint-indent :block 2 xp)
1287       (pprint-newline :linear xp)
1288       (print-clause xp)
1289       (print-and-list xp)
1290       (when (and (symbolp token)
1291            (string= (string token) "ELSE"))
1292         (print-else-or-end xp)
1293         (write-char #\space xp)
1294         (pprint-newline :linear xp)
1295         (print-clause xp)
1296         (print-and-list xp))
1297       (when (and (symbolp token)
1298            (string= (string token) "END"))
1299         (print-else-or-end xp)))))
1300       (print-and-list (xp)
1301         (loop (when (not (and (symbolp token)
1302             (string= (string token) "AND")))
1303         (return nil))
1304         (write-char #\space xp)
1305         (pprint-newline :mandatory xp)
1306         (write token :stream xp)
1307         (next-token)
1308         (write-char #\space xp)
1309         (print-clause xp)))
1310       (print-else-or-end (xp)
1311         (write-char #\space xp)
1312         (pprint-indent :block 0 xp)
1313         (pprint-newline :linear xp)
1314         (write token :stream xp)
1315         (next-token)
1316         (pprint-indent :block 2 xp)))
1317      (pprint-exit-if-list-exhausted)
1318      (write (pprint-pop) :stream xp)
1319      (next-token)
1320      (write-char #\space xp)
1321      (pprint-indent :current 0 xp)
1322      (loop (print-clause xp)
1323      (write-char #\space xp)
1324      (pprint-newline :linear xp)))))))
1325
1326;; (defun basic-write (object stream)
1327;;   (cond ((xp-structure-p stream)
1328;;          (write+ object stream))
1329;;  (*print-pretty*
1330;;          (maybe-initiate-xp-printing #'(lambda (s o) (write+ o s))
1331;;                                      stream object))
1332;;  (t
1333;;          (assert nil)
1334;;          (sys:output-object object stream))))
1335
1336(defun output-pretty-object (object stream)
1337;;   (basic-write object stream))
1338  (cond ((xp-structure-p stream)
1339         (write+ object stream))
1340  (*print-pretty*
1341         (maybe-initiate-xp-printing #'(lambda (s o) (write+ o s))
1342                                     stream object))
1343  (t
1344         (assert nil)
1345         (sys:output-object object stream))))
1346
1347(provide 'pprint)
1348
1349;------------------------------------------------------------------------
1350
1351;Copyright Massachusetts Institute of Technology, Cambridge, Massachusetts.
1352
1353;Permission to use, copy, modify, and distribute this software and its
1354;documentation for any purpose and without fee is hereby granted,
1355;provided that this copyright and permission notice appear in all
1356;copies and supporting documentation, and that the name of M.I.T. not
1357;be used in advertising or publicity pertaining to distribution of the
1358;software without specific, written prior permission. M.I.T. makes no
1359;representations about the suitability of this software for any
1360;purpose.  It is provided "as is" without express or implied warranty.
1361
1362;    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
1363;    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
1364;    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
1365;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
1366;    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
1367;    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
1368;    SOFTWARE.
1369
1370;------------------------------------------------------------------------
Note: See TracBrowser for help on using the repository browser.