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

Last change on this file was 14112, checked in by ehuelsmann, 9 years ago

Use PROVIDE/REQUIRE to prevent multiple loading.

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