source: trunk/abcl/src/org/armedbear/lisp/pprint.lisp @ 13408

Last change on this file since 13408 was 13408, checked in by ehuelsmann, 10 years ago

Fix 2 more pretty printer (PPRINT-*) test cases.

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