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

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

Eliminate a series of PPRINT.* ansi test suite failures
(dropping my test failure count from 27 to 20!).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 53.7 KB
Line 
1;;; pprint.lisp
2;;;
3;;; Copyright (C) 2004-2005 Peter Graves
4;;; $Id: pprint.lisp 13407 2011-07-15 21:18:28Z 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 (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              (xp-print fn (make-broadcast-stream) args)
618              (let ((sys::*circularity-counter* 0))
619                (xp-print fn (sys:out-synonym-of stream) args)
620                ))
621            (xp-print fn (sys:out-synonym-of stream) args))
622  *result*)))
623
624(defun xp-print (fn stream args)
625  (setq *result* (do-xp-printing fn stream args))
626  (when *locating-circularities*
627    (setq *locating-circularities* nil)
628    (setq *abbreviation-happened* nil)
629;;     (setq *parents* nil)
630    (setq *result* (do-xp-printing fn stream args))))
631
632(defun do-xp-printing (fn stream args)
633  (let ((xp (initialize-xp (make-xp-structure) stream))
634  (*current-level* 0)
635  (result nil))
636    (catch 'line-limit-abbreviation-exit
637      (start-block xp "" nil "")
638      (setq result (apply fn xp args))
639      (end-block xp nil))
640    (when (and *locating-circularities*
641         (zerop *locating-circularities*) ;No circularities.
642         (= (line-no xp) 1)       ;Didn't suppress line.
643         (zerop (buffer-offset xp)))  ;Didn't suppress partial line.
644      (setq *locating-circularities* nil))  ;print what you have got.
645    (when (catch 'line-limit-abbreviation-exit
646      (attempt-to-output xp nil t) nil)
647      (attempt-to-output xp t t))
648    result))
649
650(defun write+ (object xp)
651;;   (let ((*parents* *parents*))
652;;     (unless (and *circularity-hash-table*
653;;                  (eq (circularity-process xp object nil) :subsequent))
654;;       (when (and *circularity-hash-table* (consp object))
655;;  ;;avoid possible double check in handle-logical-block.
656;;  (setq object (cons (car object) (cdr object))))
657  (let ((printer (if *print-pretty* (get-printer object *print-pprint-dispatch*) nil))
658        type)
659    (cond (printer (funcall printer xp object))
660          ((maybe-print-fast object xp))
661          ((and *print-pretty*
662                (symbolp (setq type (type-of object)))
663                (setq printer (get type 'structure-printer))
664                (not (eq printer :none)))
665           (funcall printer xp object))
666          ((and *print-pretty* *print-array* (arrayp object)
667                (not (stringp object)) (not (bit-vector-p object))
668                (not (structure-type-p (type-of object))))
669           (pretty-array xp object))
670          (t
671           (let ((stuff (with-output-to-string (s) (non-pretty-print object s))))
672             (write-string+ stuff xp 0 (length stuff)))))))
673
674(defun non-pretty-print (object s)
675;;   (write object
676;;          :level (if *print-level*
677;;                     (- *print-level* *current-level*))
678;;          :pretty nil
679;;          :stream s))
680  (sys::output-ugly-object object s))
681
682;This prints a few very common, simple atoms very fast.
683;Pragmatically, this turns out to be an enormous savings over going to the
684;standard printer all the time.  There would be diminishing returns from making
685;this work with more things, but might be worth it.
686(defun maybe-print-fast (object xp)
687  (cond ((stringp object)
688         (let ((s (sys::%write-to-string object)))
689           (write-string++ s xp 0 (length s))
690           t))
691  ((ext:fixnump object)
692         (print-fixnum xp object)
693         t)
694  ((and (symbolp object)
695              (or (symbol-package object)
696                  (null *print-circle*)))
697         (let ((s (sys::%write-to-string object)))
698           (write-string++ s xp 0 (length s))
699           t)
700         )))
701
702(defun print-fixnum (xp fixnum)
703  (let ((s (sys::%write-to-string fixnum)))
704    (write-string++ s xp 0 (length s))))
705
706(defun print (object &optional (stream *standard-output*))
707  (setf stream (sys:out-synonym-of stream))
708  (terpri stream)
709  (let ((*print-escape* t))
710    (sys:output-object object stream))
711  (write-char #\space stream)
712  object)
713
714(defun prin1 (object &optional (stream *standard-output*))
715  (let ((*print-escape* t))
716    (sys:output-object object (sys:out-synonym-of stream)))
717  object)
718
719(defun princ (object &optional (stream *standard-output*))
720  (let ((*print-escape* nil)
721        (*print-readably* nil))
722    (sys:output-object object (sys:out-synonym-of stream)))
723  object)
724
725(defun pprint (object &optional (stream *standard-output*))
726  (setq stream (sys:out-synonym-of stream))
727  (terpri stream)
728  (let ((*print-escape* T) (*print-pretty* T))
729    (sys:output-object object stream))
730  (values))
731
732(defun write-to-string (object &key
733                               ((:escape *print-escape*) *print-escape*)
734                               ((:radix *print-radix*) *print-radix*)
735                               ((:base *print-base*) *print-base*)
736                               ((:circle *print-circle*) *print-circle*)
737                               ((:pretty *print-pretty*) *print-pretty*)
738                               ((:level *print-level*) *print-level*)
739                               ((:length *print-length*) *print-length*)
740                               ((:case *print-case*) *print-case*)
741                               ((:array *print-array*) *print-array*)
742                               ((:gensym *print-gensym*) *print-gensym*)
743                               ((:readably *print-readably*) *print-readably*)
744                               ((:right-margin *print-right-margin*) *print-right-margin*)
745                               ((:miser-width *print-miser-width*) *print-miser-width*)
746                               ((:lines *print-lines*) *print-lines*)
747                               ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*))
748  (let ((stream (make-string-output-stream)))
749    (sys:output-object object stream)
750    (get-output-stream-string stream)))
751
752(defun prin1-to-string (object)
753  (with-output-to-string (stream)
754    (let ((*print-escape* t))
755      (sys:output-object object stream))))
756
757(defun princ-to-string (object)
758  (with-output-to-string (stream)
759    (let ((*print-escape* nil)
760          (*print-readably* nil))
761      (sys:output-object object stream))))
762
763(defun write-char (char &optional (stream *standard-output*))
764  (setf stream (sys:out-synonym-of stream))
765  (if (xp-structure-p stream)
766      (write-char+ char stream)
767      (sys:%stream-write-char char stream))
768  char)
769
770(defun write-string (string &optional (stream *standard-output*)
771                            &key (start 0) end)
772  (setf stream (sys:out-synonym-of stream))
773  (setf end (or end (length string))) ;; default value for end is NIL
774  (if (xp-structure-p stream)
775      (write-string+ string stream start end)
776      (progn
777        (unless start
778          (setf start 0))
779        (if end
780            (setf end (min end (length string)))
781            (setf end (length string)))
782        (sys::%write-string string stream start end)))
783  string)
784
785(defun write-line (string &optional (stream *standard-output*)
786       &key (start 0) end)
787  (setf stream (sys:out-synonym-of stream))
788  (setf end (or end (length string)))
789  (cond ((xp-structure-p stream)
790         (write-string+ string stream start end)
791         (pprint-newline+ :unconditional stream))
792        (t (sys::%write-string string stream start end)
793           (sys::%terpri stream)))
794  string)
795
796(defun terpri (&optional (stream *standard-output*))
797  (setf stream (sys:out-synonym-of stream))
798  (if (xp-structure-p stream)
799      (pprint-newline+ :unconditional stream)
800      (sys:%stream-terpri stream))
801  nil)
802
803;This has to violate the XP data abstraction and fool with internal
804;stuff, in order to find out the right info to return as the result.
805
806(defun fresh-line (&optional (stream *standard-output*))
807  (setf stream (sys:out-synonym-of stream))
808  (cond ((xp-structure-p stream)
809   (attempt-to-output stream t t) ;ok because we want newline
810   (when (not (zerop (LP<-BP stream)))
811     (pprint-newline+ :fresh stream)
812     t))
813  (t
814         (sys::%fresh-line stream))))
815
816;Each of these causes the stream to be pessimistic and insert
817;newlines wherever it might have to, when forcing the partial output
818;out.  This is so that things will be in a consistent state if
819;output continues to the stream later.
820
821(defun finish-output (&optional (stream *standard-output*))
822  (setf stream (sys:out-synonym-of stream))
823  (when (xp-structure-p stream)
824    (attempt-to-output stream T T)
825    (setf stream (base-stream stream)))
826  (sys::%finish-output stream)
827  nil)
828
829(defun force-output (&optional (stream *standard-output*))
830  (setf stream (sys:out-synonym-of stream))
831  (when (xp-structure-p stream)
832    (attempt-to-output stream T T)
833    (setf stream (base-stream stream)))
834  (sys::%force-output stream)
835  nil)
836
837(defun clear-output (&optional (stream *standard-output*))
838  (setf stream (sys:out-synonym-of stream))
839  (when (xp-structure-p stream)
840    (let ((*locating-circularities* 0)) ;hack to prevent visible output
841      (attempt-to-output stream T T)
842      (setf stream (base-stream stream))))
843  (sys::%clear-output stream)
844  nil)
845
846;The internal functions in this file, and the (formatter "...") expansions
847;use the '+' forms of these functions directly (which is faster) because,
848;they do not need error checking or fancy stream coercion.  The '++' forms
849;additionally assume the thing being output does not contain a newline.
850
851(defmacro pprint-logical-block ((stream-symbol object
852                                               &key
853                                               (prefix "" prefix-p)
854                                               (per-line-prefix "" per-line-prefix-p)
855                                               (suffix ""))
856        &body body)
857  (cond ((eq stream-symbol nil)
858         (setf stream-symbol '*standard-output*))
859  ((eq stream-symbol t)
860         (setf stream-symbol '*terminal-io*)))
861  (unless (symbolp stream-symbol)
862    (warn "STREAM-SYMBOL arg ~S to PPRINT-LOGICAL-BLOCK is not a bindable symbol."
863    stream-symbol)
864    (setf stream-symbol '*standard-output*))
865  (when (and prefix-p per-line-prefix-p)
866    (error "Cannot specify values for both PREFIX and PER-LINE-PREFIX."))
867  `(maybe-initiate-xp-printing
868     #'(lambda (,stream-symbol)
869   (let ((+l ,object)
870               (+p ,(cond (prefix-p prefix)
871                          (per-line-prefix-p per-line-prefix)
872                          (t "")))
873         (+s ,suffix))
874     (pprint-logical-block+
875       (,stream-symbol +l +p +s ,per-line-prefix-p t nil)
876       ,@ body nil)))
877     (sys:out-synonym-of ,stream-symbol)))
878
879;Assumes var and args must be variables.  Other arguments must be literals or variables.
880
881(defmacro pprint-logical-block+ ((var args prefix suffix per-line? circle-check? atsign?)
882         &body body)
883;;    (when (and circle-check? atsign?)
884;;      (setf circle-check? 'not-first-p))
885  (declare (ignore atsign?))
886  `(let ((*current-level* (1+ *current-level*))
887   (sys:*current-print-length* -1)
888;;   ,@(if (and circle-check? atsign?)
889;;                `((not-first-p (plusp sys:*current-print-length*))))
890         )
891     (unless (check-block-abbreviation ,var ,args ,circle-check?)
892       (block logical-block
893   (start-block ,var ,prefix ,per-line? ,suffix)
894   (unwind-protect
895     (macrolet ((pprint-pop () `(pprint-pop+ ,',args ,',var))
896          (pprint-exit-if-list-exhausted ()
897      `(if (null ,',args) (return-from logical-block nil))))
898       ,@ body)
899     (end-block ,var ,suffix))))))
900
901;; "If stream is a pretty printing stream and the value of *PRINT-PRETTY* is
902;; true, a line break is inserted in the output when the appropriate condition
903;; below is satisfied; otherwise, PPRINT-NEWLINE has no effect."
904(defun pprint-newline (kind &optional (stream *standard-output*))
905  (sys:require-type kind '(MEMBER :LINEAR :MISER :FILL :MANDATORY))
906  (setq stream (sys:out-synonym-of stream))
907  (when (not (member kind '(:linear :miser :fill :mandatory)))
908    (error 'simple-type-error
909           :format-control "Invalid KIND argument ~A to PPRINT-NEWLINE."
910           :format-arguments (list kind)))
911  (when (and (xp-structure-p stream) *print-pretty*)
912    (pprint-newline+ kind stream))
913  nil)
914
915;; "If stream is a pretty printing stream and the value of *PRINT-PRETTY* is
916;; true, PPRINT-INDENT sets the indentation in the innermost dynamically
917;; enclosing logical block; otherwise, PPRINT-INDENT has no effect."
918(defun pprint-indent (relative-to n &optional (stream *standard-output*))
919  (setq stream (sys:out-synonym-of stream))
920  (when (not (member relative-to '(:block :current)))
921    (error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to))
922  (when (and (xp-structure-p stream) *print-pretty*)
923    (pprint-indent+ relative-to (truncate n) stream))
924  nil)
925
926(defun pprint-tab (kind colnum colinc &optional (stream *standard-output*))
927  (setq stream (sys:out-synonym-of stream))
928  (when (not (member kind '(:line :section :line-relative :section-relative)))
929    (error "Invalid KIND argument ~A to PPRINT-TAB" kind))
930  (when (and (xp-structure-p stream) *print-pretty*)
931    (pprint-tab+ kind colnum colinc stream))
932  nil)
933
934(eval-when (:compile-toplevel :load-toplevel :execute)
935  (defmacro pprint-pop+ (args xp)
936    `(if (pprint-pop-check+ ,args ,xp)
937         (return-from logical-block nil)
938         (pop ,args)))
939
940  (defun pprint-pop-check+ (args xp)
941    (incf sys:*current-print-length*)
942    (cond ((not (listp args))  ;must be first so supersedes length abbrev
943           (write-string++ ". " xp 0 2)
944           (sys:output-object args xp)
945           t)
946          ((and *print-length* ;must supersede circle check
947                (not *print-readably*)
948                (not (< sys:*current-print-length* *print-length*)))
949           (write-string++ "..." xp 0 3)
950;;            (setq *abbreviation-happened* T)
951           t)
952;;           ((and *circularity-hash-table* (not (zerop sys:*current-print-length*)))
953;;            (case (circularity-process xp args T)
954;;              (:first ;; note must inhibit rechecking of circularity for args.
955;;               (write+ (cons (car args) (cdr args)) xp) T)
956;;              (:subsequent t)
957;;              (t nil)))
958
959          ((or (not *print-circle*)
960               (sys::uniquely-identified-by-print-p args))
961           nil)
962
963          ((and (plusp sys:*current-print-length*)
964                (sys::check-for-circularity args))
965           (write-string++ ". " xp 0 2)
966           (sys:output-object args xp)
967           t)
968
969          ))
970
971  (defun check-block-abbreviation (xp args circle-check?)
972    (declare (ignore circle-check?))
973    (cond ((not (listp args))
974           (sys:output-object args xp) T)
975          ((and *print-level*
976                (not *print-readably*)
977                (> *current-level* *print-level*))
978           (write-char++ #\# xp)
979           (setf *abbreviation-happened* t)
980           t)
981;;           ((and *circularity-hash-table*
982;;                 circle-check?
983;;                 (eq (circularity-process xp args nil) :subsequent)) T)
984
985          (t
986           nil)))
987) ;; EVAL-WHEN
988
989;                ---- PRETTY PRINTING FORMATS ----
990
991(defun pretty-array (xp array)
992  (cond ((vectorp array)
993         (pretty-vector xp array))
994  ((zerop (array-rank array))
995         (when *print-readably*
996           (unless (eq (array-element-type array) t)
997             (error 'print-not-readable :object array)))
998   (write-string++ "#0A" xp 0 3)
999   (sys:output-object (aref array) xp))
1000  (t
1001         (pretty-non-vector xp array))))
1002
1003(defun pretty-vector (xp v)
1004  (pprint-logical-block (xp nil :prefix "#(" :suffix ")")
1005    (let ((end (length v))
1006          (i 0))
1007      (when (plusp end)
1008  (loop
1009          (pprint-pop)
1010          (sys:output-object (aref v i) xp)
1011          (when (= (incf i) end)
1012            (return nil))
1013          (write-char++ #\space xp)
1014          (pprint-newline+ :fill xp))))))
1015
1016(declaim (special *prefix*))
1017
1018(defun pretty-non-vector (xp array)
1019  (when (and *print-readably*
1020             (not (array-readably-printable-p array)))
1021    (error 'print-not-readable :object array))
1022  (let* ((bottom (1- (array-rank array)))
1023         (indices (make-list (1+ bottom) :initial-element 0))
1024         (dims (array-dimensions array))
1025         (*prefix* (cl:format nil "#~DA(" (1+ bottom))))
1026    (labels ((pretty-slice (slice)
1027               (pprint-logical-block (xp nil :prefix *prefix* :suffix ")")
1028                 (let ((end (nth slice dims))
1029                       (spot (nthcdr slice indices))
1030                       (i 0)
1031                       (*prefix* "("))
1032                   (when (plusp end)
1033                     (loop (pprint-pop)
1034                           (setf (car spot) i)
1035                           (if (= slice bottom)
1036                               (sys:output-object (apply #'aref array indices) xp)
1037                               (pretty-slice (1+ slice)))
1038                           (if (= (incf i) end) (return nil))
1039                           (write-char++ #\space xp)
1040                           (pprint-newline+ (if (= slice bottom) :fill :linear) xp)))))))
1041      (pretty-slice 0))))
1042
1043(defun array-readably-printable-p (array)
1044  (and (eq (array-element-type array) t)
1045       (let ((zero (position 0 (array-dimensions array)))
1046       (number (position 0 (array-dimensions array)
1047             :test (complement #'eql)
1048             :from-end t)))
1049   (or (null zero) (null number) (> zero number)))))
1050
1051;Must use pprint-logical-block (no +) in the following three, because they are
1052;exported functions.
1053
1054(defun pprint-linear (s list &optional (colon? T) atsign?)
1055  (declare (ignore atsign?))
1056  (pprint-logical-block (s list :prefix (if colon? "(" "")
1057              :suffix (if colon? ")" ""))
1058    (pprint-exit-if-list-exhausted)
1059    (loop
1060      (sys:output-object (pprint-pop) s)
1061      (pprint-exit-if-list-exhausted)
1062      (write-char++ #\space s)
1063      (pprint-newline+ :linear s))))
1064
1065(defun pprint-fill (stream object &optional (colon-p t) at-sign-p)
1066  (declare (ignore at-sign-p))
1067  (pprint-logical-block (stream object :prefix (if colon-p "(" "")
1068                                       :suffix (if colon-p ")" ""))
1069    (pprint-exit-if-list-exhausted)
1070    (loop
1071      (sys:output-object (pprint-pop) stream)
1072      (pprint-exit-if-list-exhausted)
1073      (write-char++ #\space stream)
1074      (pprint-newline+ :fill stream))))
1075
1076(defun pprint-tabular (stream list &optional (colon-p T) at-sign-p (tabsize nil))
1077  (declare (ignore at-sign-p))
1078  (when (null tabsize) (setq tabsize 16))
1079  (pprint-logical-block (stream list :prefix (if colon-p "(" "")
1080              :suffix (if colon-p ")" ""))
1081    (pprint-exit-if-list-exhausted)
1082    (loop
1083      (sys:output-object (pprint-pop) stream)
1084      (pprint-exit-if-list-exhausted)
1085      (write-char++ #\space stream)
1086      (pprint-tab+ :section-relative 0 tabsize stream)
1087      (pprint-newline+ :fill stream))))
1088
1089(defun fn-call (xp list)
1090  (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list))
1091
1092;Although idiosyncratic, I have found this very useful to avoid large
1093;indentations when printing out code.
1094
1095(defun alternative-fn-call (xp list)
1096  (if (> (length (symbol-name (car list))) 12)
1097      (funcall (formatter "~:<~1I~@{~W~^ ~_~}~:>") xp list)
1098      (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list)))
1099
1100(defun bind-list (xp list &rest args)
1101    (declare (ignore args))
1102  (if (do ((i 50 (1- i))
1103     (ls list (cdr ls))) ((null ls) t)
1104  (when (or (not (consp ls)) (not (symbolp (car ls))) (minusp i))
1105    (return nil)))
1106      (pprint-fill xp list)
1107      (funcall (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>") xp list)))
1108
1109(defun block-like (xp list &rest args)
1110  (declare (ignore args))
1111  (funcall (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>") xp list))
1112
1113(defun defun-like (xp list &rest args)
1114  (declare (ignore args))
1115  (funcall (formatter "~:<~1I~W~^ ~@_~W~^ ~@_~:/xp:pprint-fill/~^~@{ ~_~W~^~}~:>")
1116     xp list))
1117
1118(defun print-fancy-fn-call (xp list template)
1119  (let ((i 0) (in-first-section t))
1120    (pprint-logical-block+ (xp list "(" ")" nil t nil)
1121      (sys:output-object (pprint-pop) xp)
1122      (pprint-indent+ :current 1 xp)
1123      (loop
1124  (pprint-exit-if-list-exhausted)
1125  (write-char++ #\space xp)
1126  (when (eq i (car template))
1127    (pprint-indent+ :block (cadr template) xp)
1128    (setq template (cddr template))
1129    (setq in-first-section nil))
1130  (pprint-newline (cond ((and (zerop i) in-first-section) :miser)
1131            (in-first-section :fill)
1132            (T :linear))
1133      xp)
1134  (sys:output-object (pprint-pop) xp)
1135  (incf i)))))
1136
1137;This is an attempt to specify a correct format for every form in the CL book
1138;that does not just get printed out like an ordinary function call
1139;(i.e., most special forms and many macros).  This of course does not
1140;cover anything new you define.
1141
1142(defun let-print (xp obj)
1143  (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
1144           xp obj))
1145
1146(defun cond-print (xp obj)
1147  (funcall (formatter "~:<~W~^ ~:I~@_~@{~:/xp:pprint-linear/~^ ~_~}~:>") xp obj))
1148
1149(defun dmm-print (xp list)
1150  (print-fancy-fn-call xp list '(3 1)))
1151
1152(defun defsetf-print (xp list)
1153  (print-fancy-fn-call xp list '(3 1)))
1154
1155(defun do-print (xp obj)
1156  (funcall
1157   (formatter "~:<~W~^ ~:I~@_~/xp:bind-list/~^ ~_~:/xp:pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>")
1158   xp obj))
1159
1160(defun flet-print (xp obj)
1161  (funcall (formatter "~:<~1I~W~^ ~@_~:<~@{~/xp:block-like/~^ ~_~}~:>~^~@{ ~_~W~^~}~:>")
1162     xp obj))
1163
1164(defun function-print (xp list)
1165  (if (and (consp (cdr list)) (null (cddr list)))
1166      (funcall (formatter "#'~W") xp (cadr list))
1167      (fn-call xp list)))
1168
1169(defun mvb-print (xp list)
1170  (print-fancy-fn-call xp list '(1 3 2 1)))
1171
1172;; Used by PROG-PRINT and TAGBODY-PRINT.
1173(defun maybelab (xp item &rest args)
1174  (declare (ignore args) (special need-newline indentation))
1175  (when need-newline (pprint-newline+ :mandatory xp))
1176  (cond ((and item (symbolp item))
1177   (write+ item xp)
1178   (setq need-newline nil))
1179  (t (pprint-tab+ :section indentation 0 xp)
1180     (write+ item xp)
1181     (setq need-newline T))))
1182
1183(defun prog-print (xp list)
1184  (let ((need-newline T) (indentation (1+ (length (symbol-name (car list))))))
1185    (declare (special need-newline indentation))
1186    (funcall (formatter "~:<~W~^ ~:/xp:pprint-fill/~^ ~@{~/xp:maybelab/~^ ~}~:>")
1187       xp list)))
1188
1189(defun tagbody-print (xp list)
1190  (let ((need-newline (and (consp (cdr list))
1191         (symbolp (cadr list)) (cadr list)))
1192  (indentation (1+ (length (symbol-name (car list))))))
1193    (declare (special need-newline indentation))
1194    (funcall (formatter "~:<~W~^ ~@{~/xp:maybelab/~^ ~}~:>") xp list)))
1195
1196(defun setq-print (xp obj)
1197  (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>") xp obj))
1198
1199(defun quote-print (xp list)
1200  (if (and (consp (cdr list)) (null (cddr list)))
1201      (funcall (formatter "'~W") xp (cadr list))
1202      (pprint-fill xp list)))
1203
1204(defun up-print (xp list)
1205  (print-fancy-fn-call xp list '(0 3 1 1)))
1206
1207;here is some simple stuff for printing LOOP
1208
1209;The challange here is that we have to effectively parse the clauses of the
1210;loop in order to know how to print things.  Also you want to do this in a
1211;purely incremental way so that all of the abbreviation things work, and
1212;you wont blow up on circular lists or the like.  (More aesthic output could
1213;be produced by really parsing the clauses into nested lists before printing them.)
1214
1215;The following program assumes the following simplified grammar of the loop
1216;clauses that explains how to print them.  Note that it does not bare much
1217;resemblence to the right parsing grammar, however, it produces half decent
1218;output.  The way to make the output better is to make the grammar more
1219;detailed.
1220;
1221;loop == (LOOP {clause}*)      ;one clause on each line.
1222;clause == block | linear | cond | finally
1223;block == block-head {expr}*   ;as many exprs as possible on each line.
1224;linear == linear-head {expr}* ;one expr on each line.
1225;finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line.
1226;cond == cond-head [expr]
1227;          clause
1228;    {AND clause}*       ;one AND on each line.
1229;        [ELSE
1230;          clause
1231;    {AND clause}*]      ;one AND on each line.
1232;        [END]
1233;block-head == FOR | AS | WITH | AND
1234;              | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN
1235;              | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT
1236;              | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING
1237;linear-head == DO | DOING | INITIALLY
1238;var-head == FOR | AS | WITH
1239;cond-head == IF | WHEN | UNLESS
1240;expr == <anything that is not a head symbol>
1241
1242;Note all the string comparisons below are required to support some
1243;existing implementations of LOOP.
1244
1245(defun token-type (token &aux string)
1246  (cond ((not (symbolp token)) :expr)
1247  ((string= (setq string (string token)) "FINALLY") :finally)
1248  ((member string '("IF" "WHEN" "UNLESS") :test #'string=) :cond-head)
1249  ((member string '("DO" "DOING" "INITIALLY") :test #'string=) :linear-head)
1250  ((member string '("FOR" "AS" "WITH" "AND" "END" "ELSE"
1251        "REPEAT" "NAMED" "WHILE" "UNTIL" "ALWAYS" "NEVER"
1252        "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND"
1253        "APPENDING" "NCONC" "NCONCING" "COUNT" "COUNTING"
1254        "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING"
1255        "MINIMIZE" "MINIMIZING")
1256     :test #'string=)
1257   :block-head)
1258  (T :expr)))
1259
1260(defun pretty-loop (xp loop)
1261  (if (not (and (consp (cdr loop)) (symbolp (cadr loop)))) ; old-style loop
1262      (fn-call xp loop)
1263      (pprint-logical-block (xp loop :prefix "(" :suffix ")")
1264  (let (token type)
1265    (labels ((next-token ()
1266         (pprint-exit-if-list-exhausted)
1267         (setq token (pprint-pop))
1268         (setq type (token-type token)))
1269       (print-clause (xp)
1270         (case type
1271           (:linear-head (print-exprs xp nil :mandatory))
1272           (:cond-head (print-cond xp))
1273           (:finally (print-exprs xp T :mandatory))
1274           (otherwise (print-exprs xp nil :fill))))
1275       (print-exprs (xp skip-first-non-expr newline-type)
1276         (let ((first token))
1277           (next-token) ;so always happens no matter what
1278           (pprint-logical-block (xp nil)
1279       (write first :stream xp)
1280       (when (and skip-first-non-expr (not (eq type :expr)))
1281         (write-char #\space xp)
1282         (write token :stream xp)
1283         (next-token))
1284       (when (eq type :expr)
1285         (write-char #\space xp)
1286         (pprint-indent :current 0 xp)
1287         (loop (write token :stream xp)
1288         (next-token)
1289         (when (not (eq type :expr)) (return nil))
1290         (write-char #\space xp)
1291         (pprint-newline newline-type xp))))))
1292       (print-cond (xp)
1293         (let ((first token))
1294           (next-token) ;so always happens no matter what
1295           (pprint-logical-block (xp nil)
1296       (write first :stream xp)
1297       (when (eq type :expr)
1298         (write-char #\space xp)
1299         (write token :stream xp)
1300         (next-token))
1301       (write-char #\space xp)
1302       (pprint-indent :block 2 xp)
1303       (pprint-newline :linear xp)
1304       (print-clause xp)
1305       (print-and-list xp)
1306       (when (and (symbolp token)
1307            (string= (string token) "ELSE"))
1308         (print-else-or-end xp)
1309         (write-char #\space xp)
1310         (pprint-newline :linear xp)
1311         (print-clause xp)
1312         (print-and-list xp))
1313       (when (and (symbolp token)
1314            (string= (string token) "END"))
1315         (print-else-or-end xp)))))
1316       (print-and-list (xp)
1317         (loop (when (not (and (symbolp token)
1318             (string= (string token) "AND")))
1319         (return nil))
1320         (write-char #\space xp)
1321         (pprint-newline :mandatory xp)
1322         (write token :stream xp)
1323         (next-token)
1324         (write-char #\space xp)
1325         (print-clause xp)))
1326       (print-else-or-end (xp)
1327         (write-char #\space xp)
1328         (pprint-indent :block 0 xp)
1329         (pprint-newline :linear xp)
1330         (write token :stream xp)
1331         (next-token)
1332         (pprint-indent :block 2 xp)))
1333      (pprint-exit-if-list-exhausted)
1334      (write (pprint-pop) :stream xp)
1335      (next-token)
1336      (write-char #\space xp)
1337      (pprint-indent :current 0 xp)
1338      (loop (print-clause xp)
1339      (write-char #\space xp)
1340      (pprint-newline :linear xp)))))))
1341
1342;; (defun basic-write (object stream)
1343;;   (cond ((xp-structure-p stream)
1344;;          (write+ object stream))
1345;;  (*print-pretty*
1346;;          (maybe-initiate-xp-printing #'(lambda (s o) (write+ o s))
1347;;                                      stream object))
1348;;  (t
1349;;          (assert nil)
1350;;          (sys:output-object object stream))))
1351
1352(defun output-pretty-object (object stream)
1353;;   (basic-write object stream))
1354  (cond ((xp-structure-p stream)
1355         (write+ object stream))
1356  (*print-pretty*
1357         (maybe-initiate-xp-printing #'(lambda (s o) (write+ o s))
1358                                     stream object))
1359  (t
1360         (assert nil)
1361         (sys:output-object object stream))))
1362
1363(provide "PPRINT")
1364
1365;------------------------------------------------------------------------
1366
1367;Copyright Massachusetts Institute of Technology, Cambridge, Massachusetts.
1368
1369;Permission to use, copy, modify, and distribute this software and its
1370;documentation for any purpose and without fee is hereby granted,
1371;provided that this copyright and permission notice appear in all
1372;copies and supporting documentation, and that the name of M.I.T. not
1373;be used in advertising or publicity pertaining to distribution of the
1374;software without specific, written prior permission. M.I.T. makes no
1375;representations about the suitability of this software for any
1376;purpose.  It is provided "as is" without express or implied warranty.
1377
1378;    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
1379;    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
1380;    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
1381;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
1382;    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
1383;    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
1384;    SOFTWARE.
1385
1386;------------------------------------------------------------------------
Note: See TracBrowser for help on using the repository browser.