source: release/1.2/source/lib/pprint.lisp @ 10216

Last change on this file since 10216 was 10216, checked in by gz, 13 years ago

Merge r10214 (bug in pretty printer)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 85.8 KB
Line 
1;-*-syntax:COMMON-LISP;Package:"CCL"-*-
2
3;;      Change History (most recent first):
4;;  2 4/8/97   akh  pretty-loop dont loop
5;;  3 12/13/95 Alice Hartley no call compiler at load time
6;;  3 3/2/95   akh  will promote strings to fat strings if needed
7;;  (do not edit before this line!!)
8
9
10;------------------------------------------------------------------------
11
12;Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge,
13;Massachusetts.
14
15;Permission to use, copy, modify, and distribute this software and its
16;documentation for any purpose and without fee is hereby granted,
17;provided that this copyright and permission notice appear in all
18;copies and supporting documentation, and that the name of M.I.T. not
19;be used in advertising or publicity pertaining to distribution of the
20;software without specific, written prior permission. M.I.T. makes no
21;representations about the suitability of this software for any
22;purpose.  It is provided "as is" without express or implied warranty.
23
24;    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
25;    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
26;    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
27;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
28;    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
29;    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
30;    SOFTWARE.
31
32;------------------------------------------------------------------------
33
34;This file "XP.LISP" implements an efficient pretty printer for Common
35;Lisp.  The functions in this file are documented fully in MIT/AIM-1102a, July
36;1989.  This report can be obtained by sending $3.25 to
37
38;              Publications
39;              MIT AI Laboratory
40;              545 Tech. Sq.
41;              Cambridge MA 02139
42
43;This file attempts to be as compatible with pure Common Lisp as possible.
44;It has been tested on the following Common Lisps to date (7/31/89).
45;  Symbolics CL version 7 (does not work in version 6),
46;  LUCID CL version 3.0.2 on a sun.
47;  Allegro CL version 1.2.1 on a Macintosh.
48;  CMU CL.
49
50;The companion file "XPTEST.LISP" contains a set of 600+ tests.  You should
51;run these tests after the first time you compile this file on a new system.
52
53;The companion file "XPDOC.TXT" contains brief documentation
54; 04/05/97 akh  pretty-loop fix for *print-level* exceeded
55; 10/26/95 slh   %gvector -> %istruct
56; 08/26/93 bill  indentation
57; -------- 3.0d12
58; 06/26/93 alice stream-fresh-line (xp-stream) was producing premature newlines
59; 05/24/93 alice *free-xps* and *free-circularity-hash-tables* are global
60; 03/04/93 alice set *error-print-circle* to T
61; 02/23/93 alice get-printer - look in others table before def.., with.. hack
62; 02/15/93 alice don't unwind-protect in pprint-logical-block+
63; 12/21/92 alice lets not print loop as #'
64; 06/23/92 alice change set-pprint-dispatch+ and priority-> so '(0) is less than 0
65;--------------- 2.0
66; 02/22/92 (alice from "post 2.0f2c5:pprint-defmethod-patch") fix DEFMETHOD-LIKE.
67; -------- 2.0f2c5
68; 01/29/92 gb    pretty-structure calls structure-print-function.
69; -------- 2.0f2
70; 10/11/91 alice dont print generic-function as #'
71; 10/09/91 alice write+ don't deal with structures and arrays - prior fix was brain dead
72;    p.s. technically we shouldn't special case strings, fixnums and symbols either
73; 10/03/91 alice write+ - if print-object method for structure use it.
74; 09/25/91 alice fix circularity-process so we can rebind *print-circle* in mid stream
75; 09/25/91 alice pretty-structure - no dangling space if no slots
76; 09/24/91 alice fix pretty-structure bogus keyword printing
77; 09/11/91 alice keep first pass output until first circularity in case no circularities
78; 09/09/91 alice fix print circle in case circularity detected after first line (geez)
79;               dont die if *print-pprint-dispatch* is nil
80;--------------- 2.0b3
81; 08/21/91 gb xp-stream-stream
82; 07/21/91 gb def-accessors vice defstruct.
83; 07/09/91 alice allow write+ to tail call
84; 07/01/91 bind level and length as (f *print-readably*)
85; 07/01/91 generic-function & reinstate some MLY hacks for "def.." "with-.." etc.
86; 06/24/91 added pretty-structure
87; 05/22/91 Modified for MCL 2.0b
88;;;;;;;;;;;;;;
89;;; lisp: => cl:
90;;; string-char => character (or base-character?)
91;;; #-ccl-2 compiled format and format and much else
92;;;  put the xp-stream in the xp-structure
93;;; write-char => write-char+ in pretty-loop
94;;; nuke *last-abbreviated-printing*
95;;; Teach it about fred-special-indent-alist
96;;; in fred-alist 2 means defun-like, 0 is progn-like
97;;;   3 is defsetf-print , 1 is block-like
98;;; Put circularity table & number in the structure? - didn't do it
99;;; Nuke the xp package
100;;; Added progn-print
101;;; MAYBELAB take xp-stream or xp-structure
102;;; Gave up on #+/#-ccl-2
103;;; Could save a few hundred bytes by (funcall (formatter ...)) to (format ... )) - maybe not
104;;; The dispatch table could use some compacting: done!
105;;;  an entry contains test: 0 - must be some predicate if not of the other form
106;;;                     fn: ok
107;;;                     full-spec: '((0)(cons (member defvar)))
108;;; Nuke *print-shared* and *parents*
109;;; This version has a new special *xp-current-object* but doesnt gratuitously cons.
110;;; Fixed circle doing it twice when it needn't (what does this break?)
111;;; member => memq
112;;; Apply optimizations as Mly did in prior conversion, i.e. liberal doses
113;;; of %i+, (declare (fixnum ...)), dont fetch a stucture field 15 times
114;;; when once will suffice, no char=, fewer position & find
115;;; Now about same speed as old one. (actually 10% slower) & it conses less
116;;; In pprint-dispatch just store the function if (cons (member blah)) & (0) or 0.
117;;; nuke some entries in pprint-dispatch where same info is in fred-special-indent-alist
118;;; Size is down from 23K larger to 18K larger.
119;;; maybe-print-fast iff readtable-case is :upcase
120;;; add defmethod-like for guess what
121;;;  nuke *abbreviation-happened*
122
123
124(in-package "CCL")
125
126(defvar *ipd* nil ;see initialization at end of file.
127  "initial print dispatch table.")
128
129;default (bad) definitions for the non-portable functions
130
131(eval-when (:execute :load-toplevel :compile-toplevel)
132(defun structure-type-p (x) (structurep x))
133(defun output-width     (&optional (s *standard-output*))
134  (when (streamp s)(line-length s)))
135(defun output-position  (&optional (s *standard-output*))
136  (when (streamp s)(column s)))
137)
138
139(defvar *logical-block-p* nil
140  "True if currently inside a logical block.")
141
142(defvar *locating-circularities* nil
143  "Integer if making a first pass over things to identify circularities.
144   Integer used as counter for #n= syntax.")
145
146(def-standard-initial-binding *free-circularity-hash-tables* nil)
147
148(defun get-circularity-hash-table ()
149  (let ((table (pop *free-circularity-hash-tables*)))
150    (if table table (make-hash-table :test 'eq))))
151
152;If you call this, then the table gets efficiently recycled.
153(defun free-circularity-hash-table (table)
154  (clrhash table)
155  (pushnew table *free-circularity-hash-tables*))
156
157
158;                       ---- DISPATCHING ----
159
160(cl:defstruct (pprint-dispatch-table (:conc-name nil) (:copier nil))
161  (conses-with-cars (make-hash-table :test #'eq) :type hash-table)
162  (structures (make-hash-table :test #'eq) :type hash-table)
163  (others nil :type list))
164
165;The list and the hash-tables contain entries of the
166;following form.  When stored in the hash tables, the test entry is
167;the number of entries in the OTHERS list that have a higher priority.
168
169(progn
170(eval-when (:compile-toplevel :execute)
171  (def-accessors uvref ; %svref
172    ()                                  ;'entry
173    entry-test                          ;predicate function or count of higher priority others.
174    entry-fn                            ;pprint function
175    entry-full-spec                     ;list of priority and type specifier
176    ))
177
178(defun make-entry (&key test fn full-spec)
179  (%istruct 'entry test fn full-spec))
180)
181
182(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
183  (let* ((table (if (null table)
184                    *IPD*
185                    (require-type table '(or nil pprint-dispatch-table))))
186         (new-conses-with-cars
187           (make-hash-table :test #'eq
188             :size (max (hash-table-count (conses-with-cars table)) 32)))
189         (new-structures NIL))
190    (maphash #'(lambda (key value)
191                 (setf (gethash key new-conses-with-cars)
192                       (if (istruct-typep value 'entry)(copy-uvector value) value)))
193             (conses-with-cars table))
194    (make-pprint-dispatch-table
195      :conses-with-cars new-conses-with-cars
196      :structures new-structures
197      :others (copy-list (others table)))))
198
199(defun set-pprint-dispatch (type-specifier function
200                            &optional (priority 0) (table *print-pprint-dispatch*))
201  (when (or (not (numberp priority)) (complexp priority))
202    (error "invalid PRIORITY argument ~A to SET-PPRINT-DISPATCH" priority))
203  (set-pprint-dispatch+ type-specifier function priority table))
204
205(defun set-pprint-dispatch+ (type-specifier function priority table)
206  (let* ((category (specifier-category type-specifier))
207         (pred
208           (if (not (eq category 'other)) nil
209               (let ((pred (specifier-fn type-specifier)))
210                 (if (symbolp pred)
211                  (symbol-function pred)
212                  ; checking for (lambda (x) (foo x)) => #'foo
213                  (if (and (consp (caddr pred))
214                           (symbolp (caaddr pred)) 
215                           (equal (cdaddr pred) '(x)))
216                    (symbol-function (caaddr pred))
217                    ; calling the compiler at load time is an indictable offense
218                    (compile nil pred))))))
219         (entry (if function (make-entry :test pred
220                                         :fn function
221                                         :full-spec (list priority type-specifier)))))
222    (case category
223      (cons-with-car
224       (let ((key (cadadr type-specifier)) ;(cons (member FOO))
225             (cons-tbl (conses-with-cars table)))
226        (cond ((null function) (remhash key cons-tbl))
227              (T (let ((num 
228                       (count-if #'(lambda (e)
229                                     (priority-> e priority))
230                                 (others table))))
231                   (cond ((and (or ;(eq priority 0)
232                                   (and (consp priority)(eq (%car priority) 0)))
233                               (eq num 0))
234                          (setq entry function))
235                         (t (setf (entry-test entry) num)))
236                   (setf (gethash key cons-tbl) entry))))))
237      (T ;other
238         (let ((old (car (member type-specifier (others table) :test #'equal
239                                 :key #'(lambda (e) (cadr (entry-full-spec e)))))))
240           (when old
241             (setf (others table) (delete old (others table)))
242             (adjust-counts table (car (entry-full-spec old)) -1)))
243         (when entry
244           (let ((others (cons nil (others table))))
245              (do ((l others (cdr l)))
246                  ((null (cdr l)) (rplacd l (list entry)))
247                (when (priority-> priority (car (entry-full-spec (cadr l))))
248                  (rplacd l (cons entry (cdr l)))
249                  (return nil)))
250              (setf (others table) (cdr others)))
251           (adjust-counts table priority 1)))))
252  nil)
253
254(defun priority-> (entry-x entry-y)
255  (flet ((foo (e)
256              (cond ((istruct-typep e 'entry)(car (entry-full-spec e)))
257                    ((or (numberp e)(consp  e)) e)
258                    (t '(0)))))
259    (let ((x (foo entry-x))
260          (y (foo entry-y)))     
261      (if (consp x)
262        (if (consp y) (> (car x) (car y)) nil)
263        (if (consp y) T (> x y))))))
264
265
266(defun adjust-counts (table priority delta)
267  (maphash #'(lambda (key value)
268               (when (priority-> priority value)
269                 (when (not (istruct-typep value 'entry))
270                   (setf (gethash key (conses-with-cars table))
271                         (setq value (make-entry :fn value :test 0 :full-spec '(0)))))
272                 (incf (entry-test value) delta)))
273           (conses-with-cars table)))
274
275(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
276  (flet ((non-pretty-print (s object)
277           (write-not-pretty s object
278                             (if (get-*print-frob* '*print-level*)
279                               (- *print-level* *current-level*))
280                             nil nil)))
281    (when (null table) (setq table *IPD*)) 
282    (let ((fn (get-printer object table)))
283      (values (or fn #'non-pretty-print) (not (null fn))))))
284
285(defun get-printer (object table)
286  (when (null table)(setq table *IPD*))
287  (let* (entry)
288    (cond ((consp object)
289           (setq entry (gethash (%car object) (conses-with-cars table)))
290           (when (not entry)
291             (setq entry (find object (others table) :test #'fits))
292             (if entry
293               (setq entry (entry-fn entry)))))
294          (nil (setq entry (gethash (type-of object) (structures table)))))
295    (if (not entry)
296      (setq entry (find object (others table) :test #'fits))
297      (if (istruct-typep entry 'entry)
298        (let ((test (entry-test entry)))
299          (when (numberp test)
300            (do ((i test (1- i))
301                 (l (others table) (cdr l)))
302                ((zerop i))
303              (when (fits object (car l)) (setq entry (car l)) (return nil)))))))   
304    (when entry 
305      (if (istruct-typep entry 'entry)(entry-fn entry) entry))))
306
307(defun fits (obj entry) 
308  (funcall (entry-test entry) obj))
309
310(defun specifier-category (spec)
311  (cond ((and (consp spec)
312              (eq (car spec) 'cons)
313              (consp (cdr spec))
314              (null (cddr spec))
315              (consp (cadr spec))
316              (eq (caadr spec) 'member)
317              (consp (cdadr spec))
318              (null (cddadr spec)))
319         'cons-with-car)
320        (T 'other)))
321
322; lets make fewer things fns that compile at load time, esp anything
323; we do - really none should
324(defun specifier-fn (spec) 
325  (if (and (consp spec)(eq (car spec) 'satisfies)(symbolp (cadr spec)))
326    (cadr spec)
327    (if (and (symbolp spec)(type-predicate spec))  ; ccl specific
328      (type-predicate spec)
329      `(lambda (x) ,(convert-body spec)))))
330
331(defun convert-body (spec)
332  (cond ((atom spec) `(typep x ',spec))
333        ((member (car spec) '(and or not))
334         (cons (car spec) (mapcar #'convert-body (cdr spec))))
335        ((eq (car spec) 'member)
336         `(member x ',(copy-list (cdr spec))))
337        ((eq (car spec) 'cons)
338         `(and (consp x)
339               ,@(if (cdr spec) `((let ((x (car x)))
340                                    ,(convert-body (cadr spec)))))
341               ,@(if (cddr spec) `((let ((x (cdr x)))
342                                     ,(convert-body (caddr spec)))))))
343        ((eq (car spec) 'satisfies)
344         `(funcall (function ,(cadr spec)) x))
345        (T `(typep x ',spec))))
346
347;               ---- XP STRUCTURES, AND THE INTERNAL ALGORITHM ----
348
349(eval-when (:execute :compile-toplevel) ;not used at run time.
350  (defvar block-stack-entry-size 1)
351  (defvar prefix-stack-entry-size 5)
352  (defvar queue-entry-size 7)
353  (defvar buffer-entry-size 1)
354  (defvar prefix-entry-size 1)
355  (defvar suffix-entry-size 1))
356
357(eval-when (:execute :load-toplevel :compile-toplevel) ;used at run time
358  (defvar block-stack-min-size #.(* 35. block-stack-entry-size))
359  (defvar prefix-stack-min-size #.(* 30. prefix-stack-entry-size))
360  (defvar queue-min-size #.(* 75. queue-entry-size))
361  (defvar buffer-min-size 256.)
362  (defvar prefix-min-size 256.)
363  (defvar suffix-min-size 256.)) 
364
365(progn
366  (eval-when (:compile-toplevel :execute)
367    (def-accessors %svref
368        ()                              ; 'xp-structure
369      xp-base-stream;;The stream io eventually goes to.
370      xp-linel;;The line length to use for formatting.
371      xp-line-limit;;If non-NIL the max number of lines to print.
372      xp-line-no;;number of next line to be printed.
373      xp-char-mode;;NIL :UP :DOWN :CAP0 :CAP1 :CAPW
374      xp-char-mode-counter              ;depth of nesting of ~(...~)
375      xp-depth-in-blocks;;Number of logical blocks at QRIGHT that
376      ;;are started but not ended.             
377      xp-block-stack 
378      xp-block-stack-ptr
379      ;;This stack is pushed and popped in accordance with the way blocks are
380      ;;nested at the moment they are entered into the queue.  It contains the
381      ;;following block specific value.
382      ;;SECTION-START total position where the section (see AIM-1102)
383      ;;that is rightmost in the queue started.
384      xp-buffer
385      xp-charpos
386      xp-buffer-ptr 
387      xp-buffer-offset
388      ;;This is a vector of characters (eg a string) that builds up the
389      ;;line images that will be printed out.  BUFFER-PTR is the
390      ;;buffer position where the next character should be inserted in
391      ;;the string.  CHARPOS is the output character position of the
392      ;;first character in the buffer (non-zero only if a partial line
393      ;;has been output).  BUFFER-OFFSET is used in computing total lengths.
394      ;;It is changed to reflect all shifting and insertion of prefixes so that
395      ;;total length computes things as they would be if they were
396      ;;all on one line.  Positions are kept three different ways
397      ;; Buffer position (eg BUFFER-PTR)
398      ;; Line position (eg (+ BUFFER-PTR CHARPOS)).  Indentations are stored in this form.
399      ;; Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET))
400      ;;  Positions are stored in this form.
401      xp-queue
402      xp-qleft
403      xp-qright
404      ;;This holds a queue of action descriptors.  QLEFT and QRIGHT
405      ;;point to the next entry to dequeue and the last entry enqueued
406      ;;respectively.  The queue is empty when
407      ;;(> QLEFT QRIGHT).  The queue entries have several parts:
408      ;;QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK
409      ;;QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH
410      ;; or :BLOCK/:CURRENT
411      ;;QPOS total position corresponding to this entry
412      ;;QDEPTH depth in blocks of this entry.
413      ;;QEND offset to entry marking end of section this entry starts. (NIL until known.)
414      ;; Only :start-block and non-literal :newline entries can start sections.
415      ;;QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known).
416      ;;QARG for :IND indentation delta
417      ;;     for :START-BLOCK suffix in the block if any.
418      ;;                      or if per-line-prefix then cons of suffix and
419      ;;                      per-line-prefix.
420      ;;     for :END-BLOCK suffix for the block if any.
421      xp-prefix
422      ;;this stores the prefix that should be used at the start of the line
423      xp-prefix-stack
424      xp-prefix-stack-ptr
425      ;;This stack is pushed and popped in accordance with the way blocks
426      ;;are nested at the moment things are taken off the queue and printed.
427      ;;It contains the following block specific values.
428      ;;PREFIX-PTR current length of PREFIX.
429      ;;SUFFIX-PTR current length of pending suffix
430      ;;NON-BLANK-PREFIX-PTR current length of non-blank prefix.
431      ;;INITIAL-PREFIX-PTR prefix-ptr at the start of this block.
432      ;;SECTION-START-LINE line-no value at last non-literal break at this level.
433      xp-suffix
434      ;;this stores the suffixes that have to be printed to close of the current
435      ;;open blocks.  For convenient in popping, the whole suffix
436      ;;is stored in reverse order.
437      xp-stream  ;;; the xp-stream containing this structure
438      xp-string-stream;; string-stream for output until first circularity (in case none)
439      )
440    )
441
442  (setf (symbol-function 'xp-stream-stream) #'(lambda (s) (xp-stream s)))
443
444  (defmethod streamp ((x xp-structure)) t)
445  (defmethod streamp ((x xp-stream)) t)
446
447  (defmethod output-stream-p ((x xp-structure)) t)
448  (defmethod output-stream-p ((x xp-stream)) t)
449 
450  (defun make-xp-structure ()
451    (%istruct
452     'xp-structure
453     nil                                ; xp-base-stream
454     nil                                ; xp-linel
455     nil                                ; xp-line-limit
456     nil                                ; xp-line-no
457     nil                                ; xp-char-mode
458     nil                                ; xp-char-mode-counter
459     nil                                ; xp-depth-in-blocks
460     (make-array #.block-stack-min-size) ; xp-block-stack
461     nil                                ; xp-block-stack-ptr
462     (make-array #.buffer-min-size :element-type 'base-char)
463                                        ; use make-string and let it default?
464                                        ; xp-buffer
465     nil                                ; xp-charpos
466     nil                                ; xp-buffer-ptr
467     nil                                ; xp-buffer-offset
468     (make-array #.queue-min-size)      ; xp-queue
469     0                                  ; xp-qleft
470     0                                  ; xp-qright
471     (make-array #.buffer-min-size :element-type 'base-char)
472                                        ; xp-prefix
473     (make-array #.prefix-stack-min-size) ; xp-prefix-stack
474     nil                                ; xp-prefix-stack-ptr
475     (make-array #.buffer-min-size :element-type 'base-char)
476                                        ; xp-suffix
477     nil                                ; xp-stream
478     nil                                ; xp-string-stream
479     ))                            ; XP-STRUCTURE is a built-in class.
480
481  (defmethod write-internal-1 ((xp-struc xp-structure) object level list-kludge)
482    (write-internal-1 (xp-stream xp-struc) object level list-kludge))
483
484  (defmacro xp-structure-p (x)
485    `(istruct-typep ,x 'xp-structure))
486
487  (defun get-xp-stream (pp)
488    (xp-stream pp))
489  )
490
491
492(eval-when (:compile-toplevel :execute)
493(defmacro LP<-BP (xp &optional (ptr nil))
494  (if (null ptr) (setq ptr `(xp-buffer-ptr ,xp)))
495  `(the fixnum (%i+ ,ptr (xp-charpos ,xp))))
496(defmacro TP<-BP (xp)
497  `(the fixnum (%i+ (xp-buffer-ptr ,xp) (xp-buffer-offset ,xp))))
498(defmacro BP<-LP (xp ptr)
499  `(the fixnum (%i- ,ptr (xp-charpos ,xp))))
500(defmacro BP<-TP (xp ptr)
501  `(the fixnum (%i- ,ptr (xp-buffer-offset ,xp))))
502;This does not tell you the line position you were at when the TP
503;was set, unless there have been no newlines or indentation output
504;between ptr and the current output point.
505(defmacro LP<-TP (xp ptr)
506  `(LP<-BP ,xp (BP<-TP ,xp ,ptr)))
507
508;We don't use adjustable vectors or any of that, because we seldom have
509;to actually extend and non-adjustable vectors are a lot faster in
510;many Common Lisps.
511
512(defmacro xp-check-size (FORM ptr min-size entry-size
513                           &optional (type 'simple-vector))
514  `(let ((.old. ,form)
515         (.ptr. ,ptr))
516     (declare (type ,type .old.) (type fixnum .ptr.))
517     (if (and (ccl::%i> .ptr. ,(- min-size entry-size)) ;seldom haxpens
518              (ccl::%i> .ptr. (- (length (the ,type .old.)) ,entry-size)))
519         (let ((.new. ,(let ((l `(ccl::%i+ .ptr. ,(if (= entry-size 1)
520                                                    50
521                                                    (* 10 entry-size)))))
522                         `(make-array ,l :element-type (array-element-type .old.)))))
523           ;;>>
524           (replace .new. .old.)
525           (setf ,form .new.))
526         .old.)))
527
528(defmacro section-start (xp) `(svref (xp-block-stack ,xp) (xp-block-stack-ptr ,xp)))
529) ; eval-when
530
531;               ---- CCL specific METHODS --------
532(progn
533(defmethod stream-write-char ((stream xp-stream) char)
534  (write-char+ char (slot-value stream 'xp-structure))
535  char)
536
537(defmethod stream-write-char ((stream xp-structure) char)
538  (write-char+ char stream)
539  char)
540
541(defmethod stream-write-string ((stream xp-stream) string &optional (start 0) end)
542  (setq end (check-sequence-bounds string start end))
543  (write-string+ string (slot-value stream 'xp-structure) start end)
544  string)
545
546(defmethod stream-write-string ((stream xp-structure) string &optional (start 0) end)
547  (setq end (check-sequence-bounds string start end))
548  (write-string+ string stream start end)
549  string)
550
551; If we really don't care about the value returned then just
552; plain (pprint-newline+ :fresh xp) is fine.
553(defmethod stream-fresh-line ((stream xp-stream))
554  (let ((xp (slot-value stream 'xp-structure)))
555    (attempt-to-output xp nil nil)  ; was (attempt-to-output xp T T)
556    (prog1 (not (zerop (LP<-BP xp)))     
557      (pprint-newline+ :fresh xp))))
558
559
560(defmethod stream-finish-output ((stream xp-stream))
561  (attempt-to-output (slot-value stream 'xp-structure) t t))
562
563(defmethod stream-force-output ((stream xp-stream))
564  (attempt-to-output (slot-value stream 'xp-structure) t t)
565  nil)
566
567(defmethod stream-clear-output ((stream xp-stream))
568  (let ((*locating-circularities* 1)) ;hack to prevent visible output
569    (attempt-to-output (slot-value stream 'xp-structure) T T))
570  nil)
571
572(defmethod stream-line-column ((stream xp-stream))
573  (LP<-BP (slot-value stream 'xp-structure)))
574
575(defmethod stream-line-length ((stream xp-stream))
576  (xp-linel (slot-value stream 'xp-structure)))
577
578)
579
580
581(defun push-block-stack (xp)
582  (let ((ptr (%i+ (xp-block-stack-ptr xp) #.block-stack-entry-size)))
583    (setf (xp-block-stack-ptr xp) ptr)
584    (xp-check-size (xp-block-stack xp) ptr
585                   #.block-stack-min-size #.block-stack-entry-size)))
586
587(eval-when (:compile-toplevel :execute)
588(defmacro prefix-ptr (xp)
589  `(svref (xp-prefix-stack ,xp) (xp-prefix-stack-ptr ,xp)))
590(defmacro suffix-ptr (xp)
591  `(svref (xp-prefix-stack ,xp) (%i+ (xp-prefix-stack-ptr ,xp) 1)))
592(defmacro non-blank-prefix-ptr (xp)
593  `(svref (xp-prefix-stack ,xp) (%i+ (xp-prefix-stack-ptr ,xp) 2)))
594(defmacro initial-prefix-ptr (xp)
595  `(svref (xp-prefix-stack ,xp) (%i+ (xp-prefix-stack-ptr ,xp) 3)))
596(defmacro section-start-line (xp)
597  `(svref (xp-prefix-stack ,xp) (%i+ (xp-prefix-stack-ptr ,xp) 4)))
598
599(defmacro stk-prefix-ptr (stk ptr)
600  `(svref ,stk ,ptr))
601(defmacro stk-suffix-ptr (stk ptr)
602  `(svref ,stk (%i+ ,ptr 1)))
603(defmacro stk-non-blank-prefix-ptr (stk ptr)
604  `(svref ,stk (%i+ ,ptr 2)))
605) ; EVAL-when
606
607
608; saves 100 bytes and a microsecond or 2
609(defun push-prefix-stack (xp)
610  (let ((old-prefix 0)
611        (old-suffix 0) 
612        (old-non-blank 0)
613        (stack (xp-prefix-stack xp))
614        (ptr (xp-prefix-stack-ptr xp)))
615    (declare (fixnum ptr))
616    (when (>= ptr 0)
617      (setq old-prefix (stk-prefix-ptr stack ptr)
618            old-suffix (stk-suffix-ptr stack ptr)
619            old-non-blank (stk-non-blank-prefix-ptr stack ptr)))
620    (setq ptr (%i+ ptr #.prefix-stack-entry-size))
621    (setf (xp-prefix-stack-ptr xp) ptr)
622    (setq stack
623          (xp-check-size (xp-prefix-stack xp) ptr
624                   #.prefix-stack-min-size #.prefix-stack-entry-size))
625    (setf (stk-prefix-ptr stack ptr) old-prefix)
626    (setf (stk-suffix-ptr stack ptr) old-suffix)
627    (setf (stk-non-blank-prefix-ptr stack ptr) old-non-blank)))
628
629
630
631(eval-when (:compile-toplevel :execute)
632(defmacro Qtype   (xp index) `(svref (xp-queue ,xp) ,index))
633(defmacro Qkind   (xp index) `(svref (xp-queue ,xp) (1+ ,index)))
634(defmacro Qpos    (xp index) `(svref (xp-queue ,xp) (+ ,index 2)))
635(defmacro Qdepth  (xp index) `(svref (xp-queue ,xp) (+ ,index 3)))
636(defmacro Qend    (xp index) `(svref (xp-queue ,xp) (+ ,index 4)))
637(defmacro Qoffset (xp index) `(svref (xp-queue ,xp) (+ ,index 5)))
638(defmacro Qarg    (xp index) `(svref (xp-queue ,xp) (+ ,index 6)))
639(defmacro xpq-type (queue index)
640  `(svref ,queue ,index))
641(defmacro xpq-kind (queue index)
642  `(svref ,queue (ccl::%i+ ,index 1)))
643(defmacro xpq-pos (queue index)
644  `(svref ,queue (ccl::%i+ ,index 2)))
645(defmacro xpq-depth (queue index)
646  `(svref ,queue (ccl::%i+ ,index 3)))
647(defmacro xpq-end (queue index)
648  `(svref ,queue (ccl::%i+ ,index 4)))
649(defmacro xpq-offset (queue index)
650  `(svref ,queue (ccl::%i+ ,index 5)))
651(defmacro xpq-arg (queue index)
652  `(svref ,queue (ccl::%i+ ,index 6)))
653) ; eval-when
654
655;we shift the queue over rather than using a circular queue because
656;that works out to be a lot faster in practice.  Note, short printout
657;does not ever cause a shift, and even in long printout, the queue is
658;shifted left for free every time it happens to empty out.
659
660(defun enqueue (xp type kind &optional arg) 
661  (let ((queue (xp-queue xp))
662        (qright (ccl::%i+ (xp-qright xp) #.queue-entry-size))
663        (qleft (xp-qleft xp)))
664    (declare (type fixnum qright qleft) (type simple-vector queue))
665    (when (ccl::%i> qright #.(- queue-min-size queue-entry-size))
666      ;;>> generic
667      (replace queue queue :start2 qleft :end2 qright)
668      (setf (xp-qleft xp) 0
669            qright (ccl::%i- qright qleft)))
670    (setq queue (xp-check-size (xp-queue  xp) qright
671                               #.queue-min-size #.queue-entry-size))
672    (setf (xp-qright xp) qright
673          (xpq-type queue qright) type
674          (xpq-kind queue qright) kind
675          (xpq-pos queue qright) (TP<-BP xp)
676          (xpq-depth queue qright) (xp-depth-in-blocks xp)
677          (xpq-end queue qright) nil
678          (xpq-offset queue qright) nil
679          (xpq-arg queue qright) arg)))
680
681(defmacro Qnext (index) `(%i+ ,index #.queue-entry-size))
682
683
684;This maintains a list of XP structures.  We save them
685;so that we don't have to create new ones all of the time.
686;We have separate objects so that many can be in use at once.
687
688;(Note should really be doing some locking here, but CL does not have the
689;primitives for it.  There is a tiny probability here that two different
690;processes could end up trying to use the same xp-stream)
691
692(def-standard-initial-binding *free-xps* nil) ;free list of XP stream objects
693
694(defun get-pretty-print-stream (stream)
695  (let ((xp (without-interrupts (pop *free-xps*))))
696    (when (not xp)(setq xp (make-xp-structure)))
697    (initialize-xp xp stream)
698    (let ((the-xp-stream (make-instance  'xp-stream)))
699      (setf (slot-value the-xp-stream 'xp-structure) xp)
700      (setf (xp-stream xp) the-xp-stream) ; lets be circular
701      the-xp-stream)))
702
703;If you call this, the xp-stream gets efficiently recycled.
704
705(defun free-pretty-print-stream (xp)
706  (setf (xp-base-stream xp) nil)
707  (pushnew xp *free-xps*))
708
709;This is called to initialize things when you start pretty printing.
710
711(defun initialize-xp (xp stream)
712  (setf (xp-base-stream xp) stream)
713  (setf (xp-linel xp) (max 0 (cond (*print-right-margin*)
714                                           ((output-width stream))
715                                           (T *default-right-margin*))))
716  (setf (xp-line-limit xp) *print-lines*)
717  (setf (xp-line-no xp) 1)
718  (setf (xp-char-mode xp) nil)
719  (setf (xp-char-mode-counter xp) 0)
720  (setf (xp-depth-in-blocks xp) 0)
721  (setf (xp-block-stack-ptr xp) 0)
722  (setf (xp-charpos xp) (cond ((output-position stream)) (T 0)))
723  (setf (section-start xp) 0)
724  (setf (xp-buffer-ptr xp) 0)
725  (setf (xp-buffer-offset xp) (xp-charpos xp))
726  (setf (xp-qleft xp) 0)
727  (setf (xp-qright xp) #.(- queue-entry-size))
728  (setf (xp-prefix-stack-ptr xp) #.(- prefix-stack-entry-size))
729  (let ((s (xp-string-stream xp)))
730    (when s (stream-position s 0)))
731  xp)
732
733;The char-mode stuff is a bit tricky.
734;one can be in one of the following modes:
735;NIL no changes to characters output.
736;:UP CHAR-UPCASE used.
737;:DOWN CHAR-DOWNCASE used.
738;:CAP0 capitalize next alphanumeric letter then switch to :DOWN.
739;:CAP1 capitalize next alphanumeric letter then switch to :CAPW
740;:CAPW downcase letters.  When a word break letter found, switch to :CAP1.
741;It is possible for ~(~) to be nested in a format string, but note that
742;each mode specifies what should happen to every letter.  Therefore, inner
743;nested modes never have any effect.  You can just ignore them.
744
745(defun push-char-mode (xp new-mode)
746  (if (zerop (xp-char-mode-counter xp))
747      (setf (xp-char-mode xp) new-mode))
748  (incf (xp-char-mode-counter xp)))
749
750(defun pop-char-mode (xp)
751  (decf (xp-char-mode-counter xp))
752  (if (zerop (xp-char-mode-counter xp))
753      (setf (xp-char-mode xp) nil)))
754
755;Assumes is only called when char-mode is non-nil
756(defun handle-char-mode (xp char)
757  (case (xp-char-mode xp)
758    (:CAP0 (cond ((not (alphanumericp char)) char)
759                 (T (setf (xp-char-mode xp) :DOWN) (char-upcase char))))
760    (:CAP1 (cond ((not (alphanumericp char)) char)
761                 (T (setf (xp-char-mode xp) :CAPW) (char-upcase char))))
762    (:CAPW (cond ((alphanumericp char) (char-downcase char))
763                 (T (setf (xp-char-mode xp) :CAP1) char)))
764    (:UP (char-upcase char))
765    (T (char-downcase char)))) ;:DOWN
766
767;All characters output are passed through the handler above.  However, it must
768;be noted that on-each-line prefixes are only processed in the context of the
769;first place they appear.  They stay the same later no matter what.  Also
770;non-literal newlines do not count as word breaks.
771
772
773;This handles the basic outputting of characters.  note + suffix means that
774;the stream is known to be an XP stream, all inputs are mandatory, and no
775;error checking has to be done.  Suffix ++ additionally means that the
776;output is guaranteed not to contain a newline char.
777
778(defun write-char+ (char xp)
779  (if (eql char #\newline) (pprint-newline+ :unconditional xp)
780      (write-char++ char xp)))
781
782(defun write-string+ (string xp start end)
783  (let ((sub-end nil) next-newline)
784    (loop (setq next-newline
785                (if (typep string 'simple-string)
786                  (%str-member #\newline string start end)
787                  (position #\newline string :start start :end end :test #'eq )))
788          (setq sub-end (if next-newline next-newline end))
789          (write-string++ string xp start sub-end)
790          (when (null next-newline) (return nil))
791          (pprint-newline+ :unconditional xp)
792          (setq start (%i+ 1 sub-end)))))
793
794
795
796;note this checks (> BUFFER-PTR LINEL) instead of (> (LP<-BP) LINEL)
797;this is important so that when things are longer than a line they
798;end up getting printed in chunks of size LINEL.
799
800(defun write-char++ (char xp)
801  (when (> (xp-buffer-ptr xp) (xp-linel xp))
802    (force-some-output xp))
803  (let ((new-buffer-end (%i+ 1 (xp-buffer-ptr xp))))
804    (xp-check-size (xp-buffer xp) new-buffer-end #.buffer-min-size #.buffer-entry-size)
805    (if (xp-char-mode xp) (setq char (handle-char-mode xp char)))
806    (setf (schar (xp-buffer xp) (xp-buffer-ptr xp)) char)   
807    (setf (xp-buffer-ptr xp) new-buffer-end)))
808
809
810(defun force-some-output (xp)
811  (attempt-to-output xp nil nil)
812  (when (> (xp-buffer-ptr xp) (xp-linel xp)) ;only if printing off end of line
813    (attempt-to-output xp T T)))
814
815(defun write-string++ (string xp start end)
816  (when (> (xp-buffer-ptr xp) (xp-linel xp))
817    (force-some-output xp))
818  (write-string+++ string xp start end))
819
820;never forces output; therefore safe to call from within output-line.
821
822(defun write-string+++ (string xp start end)
823  (declare (fixnum start end))
824  (let ((new-buffer-end (%i+ (xp-buffer-ptr xp) (- end start))))
825    (xp-check-size (xp-buffer xp) new-buffer-end #.buffer-min-size #.buffer-entry-size)
826    (do ((buffer (xp-buffer xp))
827         (i (xp-buffer-ptr xp) (1+ i))
828         (j start (1+ j)))
829        ((= j end))
830      (declare (fixnum i j))
831      (let ((char (char string j)))
832        (if (xp-char-mode xp) (setq char (handle-char-mode xp char)))     
833        (setf (schar buffer i) char)))
834    (setf (xp-buffer-ptr xp) new-buffer-end)))
835
836(defun pprint-tab+ (kind colnum colinc xp)
837  (let ((indented? nil) (relative? nil))
838    (declare (fixnum colnum colinc))
839    (case kind
840      (:section (setq indented? T))
841      (:line-relative (setq relative? T))
842      (:section-relative (setq indented? T relative? T)))
843    (when (or (not indented?)
844              (and *print-pretty* *logical-block-p*))
845      (let* ((current
846              (if (not indented?) (LP<-BP xp)
847                  (%i- (TP<-BP xp) (section-start xp))))
848             (new
849              (if (zerop colinc)
850                  (if relative? (+ current colnum) (max colnum current))
851                  (cond (relative?
852                         (* colinc (floor (+ current colnum colinc -1) colinc)))
853                        ((> colnum current) colnum)
854                        (T (+ colnum
855                              (* colinc
856                                 (floor (+ current (- colnum) colinc) colinc)))))))
857             (length (- new current)))
858        (declare (fixnum current new length))
859        (when (plusp length)
860          (if (xp-char-mode xp) (handle-char-mode xp #\space))
861          (let ((end (%i+ (xp-buffer-ptr xp) length)))
862            (xp-check-size (xp-buffer xp) end #.buffer-min-size #.buffer-entry-size)
863            (fill (xp-buffer xp) #\space :start (xp-buffer-ptr xp) :end end)
864            (setf (xp-buffer-ptr xp) end)))))))
865
866;note following is smallest number >= x that is a multiple of colinc
867;  (* colinc (floor (+ x (1- colinc)) colinc))
868
869(defun pprint-newline+ (kind xp)
870  (enqueue xp :newline kind)
871  (let ((queue (xp-queue xp))
872        (qright (xp-qright xp)))
873    (declare (fixnum qright))
874    (do ((ptr (xp-qleft xp) (Qnext ptr))) ;find sections we are ending
875        ((not (< ptr qright)))            ;all but last
876      (declare (fixnum ptr))
877      (when (and (null (xpq-end queue ptr))
878                 (not (%i> (xp-depth-in-blocks xp) (xpq-depth queue ptr)))
879                 (memq (xpq-type queue ptr) '(:newline :start-block)))
880        (setf (xpq-end queue ptr) (- qright ptr))))
881    (setf (section-start xp) (TP<-BP xp))
882    (when (and (memq kind '(:fresh :unconditional)) (xp-char-mode xp))
883      (handle-char-mode xp #\newline))
884    (when (memq kind '(:fresh :unconditional :mandatory))
885      (attempt-to-output xp T nil))))
886
887(defun start-block (xp prefix-string on-each-line? suffix-string)
888  (macrolet ((push-block-stack (xp)
889               `(let ((ptr (%i+ (xp-block-stack-ptr ,xp) #.block-stack-entry-size)))
890                  (setf (xp-block-stack-ptr ,xp) ptr)
891                  (xp-check-size (xp-block-stack ,xp) ptr
892                                 #.block-stack-min-size #.block-stack-entry-size))))
893    (let ((length (if prefix-string (length (the string prefix-string)) 0)))       
894      (declare (fixnum length))
895      (when prefix-string (write-string++ prefix-string xp 0 length))   
896      (if (and (xp-char-mode xp) on-each-line?)
897        (let ((ptr (xp-buffer-ptr xp)))
898          (declare (fixnum ptr))
899          (setq prefix-string
900                (%substr (xp-buffer xp) (- ptr length) ptr))))
901      (push-block-stack xp)
902      (enqueue xp :start-block nil
903               (if on-each-line? (cons suffix-string prefix-string) suffix-string))
904      (setf (xp-depth-in-blocks xp)(%i+ 1 (xp-depth-in-blocks xp)))      ;must be after enqueue
905      (setf (section-start xp) (TP<-BP xp)))))
906
907(defun end-block (xp suffix)
908  (macrolet ((pop-block-stack (xp)
909               `(decf (the fixnum (xp-block-stack-ptr ,xp)) #.block-stack-entry-size)))
910    ;(unless (eq *abbreviation-happened* '*print-lines*)
911      (when suffix (write-string+ suffix xp 0 (length suffix)))
912      (decf (xp-depth-in-blocks xp))
913      (enqueue xp :end-block nil suffix)
914      (let ((queue (xp-queue xp))
915            (qright (xp-qright xp)))
916        (declare (fixnum qright))
917        (do ((ptr (xp-qleft xp) (Qnext ptr))) ;looking for start of block we are ending
918            ((not (< ptr qright)))    ;all but last
919          (declare (fixnum ptr))
920          (when (and (= (the fixnum (xp-depth-in-blocks xp)) (the fixnum (xpq-depth queue ptr)))
921                     (eq (xpq-type queue ptr) :start-block)
922                     (null (xpq-offset queue ptr)))
923            (setf (xpq-offset queue ptr) (- qright ptr))
924            (return nil)))      ;can only be 1
925        (pop-block-stack xp)))) ;)
926
927(defun pprint-indent+ (kind n xp)
928  (when (and *print-pretty* *logical-block-p*)
929    (enqueue xp :ind kind n)))
930
931; The next function scans the queue looking for things it can do.
932;it keeps outputting things until the queue is empty, or it finds
933;a place where it cannot make a decision yet.
934
935(eval-when (:compile-toplevel :execute)
936(defmacro maybe-too-large (xp Qentry queue linel)
937  `(let ((.limit. ,linel)
938         (.qend. (xpq-end ,queue ,qentry)))
939     (declare (fixnum .limit.))
940     (when (eql (xp-line-limit ,xp) (xp-line-no ,xp)) ;prevents suffix overflow
941       (decf .limit. 2) ;3 for " .." minus 1 for space (heuristic)
942       (when (not (minusp (xp-prefix-stack-ptr ,xp)))
943         (decf .limit. (suffix-ptr ,xp))))
944     (cond (.qend.
945            (%i> (LP<-TP ,xp (xpq-pos ,queue (%i+ ,Qentry .qend.))) .limit.))
946           ((or force-newlines? (%i> (LP<-BP ,xp) .limit.)) T)
947           (T (return nil)))))  ;wait until later to decide.
948
949(defmacro misering? (xp left)
950  `(<= ,left
951       (the fixnum (initial-prefix-ptr ,xp))))
952) ; eval-when
953
954;If flush-out? is T and force-newlines? is NIL then the buffer,
955;prefix-stack, and queue will be in an inconsistent state after the call.
956;You better not call it this way except as the last act of outputting.
957
958
959(defun attempt-to-output (xp force-newlines? flush-out?)
960  (macrolet ((pop-prefix-stack (xp)             
961             `(decf (the fixnum (xp-prefix-stack-ptr ,xp))
962                #.prefix-stack-entry-size)))
963  (let* ((width  *print-miser-width*)
964         (linel (xp-linel xp))
965         (left  (if width (- linel width) most-positive-fixnum)))
966    (declare (fixnum linel left))
967  (do ((qleft (xp-qleft xp))
968       (queue (xp-queue xp)(xp-queue xp)))
969      ((%i> qleft (xp-qright xp))
970          (setf (xp-qleft xp) 0)
971          (setf (xp-qright xp) #.(- queue-entry-size))) ;saves shifting
972    ; initial-prefix-ptr cant be referenced initially - prefix-stack-ptr is negative
973    (case (xpq-type queue qleft)
974      (:ind
975       (unless (misering? xp left)
976         (set-indentation-prefix xp
977           (case (xpq-kind queue qleft)
978             (:block (%i+ (initial-prefix-ptr xp) (xpq-arg queue qleft)))
979             (T ; :current
980               (%i+ (LP<-TP xp (xpq-pos queue qleft))
981                  (xpq-arg queue qleft)))))) )
982      (:start-block
983       (cond ((maybe-too-large xp qleft queue linel)
984              (push-prefix-stack xp)
985              (setf (initial-prefix-ptr xp) (prefix-ptr xp))
986              (set-indentation-prefix xp (LP<-TP xp (xpq-pos queue qleft)))
987              (let ((arg (xpq-arg queue qleft)))
988                (when (consp arg) (set-prefix xp (cdr arg)))
989                (setf (initial-prefix-ptr xp) (prefix-ptr xp))
990                (cond ((not (listp arg)) (set-suffix xp arg))
991                      ((car arg) (set-suffix xp (car arg)))))
992              (setf (section-start-line xp) (xp-line-no xp)))
993             (T (setq qleft (%i+ qleft (xpq-offset queue qleft))))) )
994      (:end-block (pop-prefix-stack xp))
995      (T ; :newline
996       (when (case (xpq-kind queue qleft)
997               (:fresh (not (%izerop (LP<-BP xp))))
998               (:miser (misering? xp left))
999               (:fill (or (misering? xp left)
1000                          (%i> (xp-line-no xp) (section-start-line xp))
1001                          (maybe-too-large xp qleft queue linel)))
1002               (T T)) ;(:linear :unconditional :mandatory)
1003         (output-line xp qleft)
1004         (setup-for-next-line xp qleft))))
1005    (setf (xp-qleft xp) (setq qleft (qnext qleft))))
1006  (when flush-out? (flush xp)))))
1007
1008
1009(defun flush (xp)
1010  (let ((ostream (xp-out-stream xp)))
1011    (when ostream     
1012      (write-string (xp-buffer xp) ostream :start 0 :end (xp-buffer-ptr xp)))
1013    (incf (xp-buffer-offset xp) (xp-buffer-ptr xp))
1014    (incf (xp-charpos xp) (xp-buffer-ptr xp))
1015    (setf (xp-buffer-ptr xp) 0)))
1016
1017
1018(defun xp-out-stream (xp)
1019  (let ((lc *locating-circularities*))
1020    (cond 
1021     ((null lc)
1022      (xp-base-stream xp))
1023     ((= lc 0)
1024      (if  (null (xp-string-stream xp))
1025        (setf (xp-string-stream xp) (make-string-output-stream))
1026        (xp-string-stream xp))))))
1027 
1028
1029;This prints out a line of stuff.
1030
1031(defun output-line (xp Qentry)
1032  (flet ((find-not-char-reverse (buffer out-point)
1033           (declare (type simple-base-string buffer) (type fixnum out-point))
1034           (do ((i (%i- out-point 1) (%i- i 1)))
1035               ((%i< i 0) nil)
1036             (when (or (neq (schar buffer i) #\Space)
1037                       ;; Don't match possibly-quoted space ("possibly" because the #\\ itself might be
1038                       ;; quoted; don't bother checking for that, no big harm leaving the space even if
1039                       ;; not totally necessary).
1040                       (and (%i< 0 i) (eq (schar buffer (%i- i 1)) #\\)))
1041               (return i)))))
1042    (let* ((queue (xp-queue xp))
1043           (out-point (BP<-TP xp (xpq-pos queue Qentry)))
1044           (last-non-blank (find-not-char-reverse (xp-buffer xp) out-point))
1045           (end (cond ((memq (xpq-kind queue Qentry) '(:fresh :unconditional)) out-point)
1046                      (last-non-blank (%i+ 1 last-non-blank))
1047                      (T 0)))
1048           (line-limit-exit (and (xp-line-limit xp) (not (%i> (xp-line-limit xp) (xp-line-no xp))))))
1049      (when line-limit-exit
1050        (setf (xp-buffer-ptr xp) end)          ;truncate pending output.
1051        (write-string+++ " .." xp 0 3)
1052        (reverse-string-in-place (xp-suffix xp) 0 (suffix-ptr xp))
1053        (write-string+++ (xp-suffix xp) xp 0 (suffix-ptr xp))
1054        (setf (xp-qleft xp) (qnext (xp-qright xp)))
1055        ;(setq *abbreviation-happened* '*print-lines*)
1056        (throw 'line-limit-abbreviation-exit T))
1057      (setf (xp-line-no xp)(%i+ 1 (xp-line-no xp)))
1058      (let ((bstream (xp-out-stream xp)))
1059        (when bstream
1060          (write-string (xp-buffer xp) bstream :start 0 :end end)
1061          (stream-write-char bstream #\newline))))))
1062
1063(defun setup-for-next-line (xp Qentry)
1064  (let* ((queue (xp-queue xp))
1065         (out-point (BP<-TP xp (xpq-pos queue Qentry)))
1066         (prefix-end
1067          (cond ((memq (xpq-kind queue Qentry) '(:unconditional :fresh))
1068                 (non-blank-prefix-ptr xp))
1069                (T (prefix-ptr xp))))
1070         (change (- prefix-end out-point)))
1071    (declare (fixnum out-point prefix-end change))
1072    (setf (xp-charpos xp) 0)
1073    (when (plusp change)                  ;almost never happens
1074      (xp-check-size (xp-buffer xp) (%i+ (xp-buffer-ptr xp) change)
1075                     #.buffer-min-size #.buffer-entry-size))
1076    (let ((buffer (xp-buffer xp)))
1077      (replace buffer buffer :start1 prefix-end
1078               :start2 out-point :end2 (xp-buffer-ptr xp))
1079      (replace buffer (xp-prefix xp) :end2 prefix-end)
1080      (setf (xp-buffer-ptr xp) (%i+ (xp-buffer-ptr xp) change))
1081      (setf (xp-buffer-offset xp) (%i- (xp-buffer-offset xp) change))
1082      (when (not (memq (xpq-kind queue Qentry) '(:unconditional :fresh)))
1083        (setf (section-start-line xp) (xp-line-no xp))))))
1084
1085(defun set-indentation-prefix (xp new-position)
1086  (let ((new-ind (max (non-blank-prefix-ptr xp) new-position)))
1087    (declare (fixnum new-ind))
1088    (setf (prefix-ptr xp) (initial-prefix-ptr xp))
1089    (xp-check-size (xp-prefix xp) new-ind #.prefix-min-size #.prefix-entry-size)
1090    (when (%i> new-ind (prefix-ptr xp))
1091      (fill (xp-prefix xp) #\space :start (prefix-ptr xp) :end new-ind))
1092    (setf (prefix-ptr xp) new-ind)))
1093
1094(defun set-prefix (xp prefix-string)
1095  (declare (string prefix-string))
1096  (replace (xp-prefix xp) prefix-string
1097           :start1 (%i- (prefix-ptr xp) (length prefix-string)))
1098  (setf (non-blank-prefix-ptr xp) (prefix-ptr xp)))
1099
1100(defun set-suffix (xp suffix-string)
1101  (declare (string suffix-string))
1102  (let* ((end (length suffix-string))
1103         (new-end (%i+ (suffix-ptr xp) end)))
1104    (declare (fixnum end new-end))
1105    (xp-check-size (xp-suffix xp) new-end #.suffix-min-size #.suffix-entry-size)
1106    (do ((i (1- new-end) (1- i)) (j 0 (1+ j))) ((= j end))
1107      (declare (fixnum i j))
1108      (setf (char (xp-suffix xp) i) (char suffix-string j)))
1109    (setf (suffix-ptr xp) new-end)))
1110
1111(defun reverse-string-in-place (string start end)
1112  (declare (fixnum start end))
1113  (do ((i start (1+ i)) (j (1- end) (1- j))) ((not (< i j)) string)
1114    (declare (fixnum i j))
1115    (let ((c (schar string i)))
1116      (setf (schar string i) (schar string j))
1117      (setf (schar string j) c))))
1118
1119;                  ---- BASIC INTERFACE FUNCTIONS ----
1120
1121;The internal functions in this file, and the (formatter "...") expansions
1122;use the '+' forms of these functions directly (which is faster) because,
1123;they do not need error checking of fancy stream coercion.  The '++' forms
1124;additionally assume the thing being output does not contain a newline.
1125
1126(defun maybe-initiate-xp-printing (fn stream &rest args)
1127  (if (xp-structure-p stream) (apply fn stream args)
1128    (if (typep stream 'xp-stream)
1129      (apply fn (slot-value stream 'xp-structure) args)
1130      (let ((*locating-circularities* (if *print-circle* 0 nil))
1131            (*circularity-hash-table*
1132             (if *print-circle* (get-circularity-hash-table) nil)))
1133        (prog1 (xp-print fn (decode-stream-arg stream) args)
1134          (if *circularity-hash-table*
1135            (free-circularity-hash-table *circularity-hash-table*)))))))
1136
1137(defun xp-print (fn stream args)
1138  (flet ((do-it (fn stream args)
1139           (prog1 (do-xp-printing fn stream args)
1140             (when *locating-circularities*
1141               (setq *locating-circularities* nil)
1142               (do-xp-printing fn stream args)))))
1143    (cond (*print-readably*
1144           (let* ((*print-level* nil)
1145                  (*print-length* nil)
1146                  (*print-lines* nil)
1147                  (*print-escape* t)
1148                  (*print-gensym* t)
1149                  (*print-array* nil))
1150             (do-it fn stream args)))
1151          (t (do-it fn stream args)))))
1152
1153(defun decode-stream-arg (stream)
1154  (cond ((eq stream T) *terminal-io*)
1155        ((null stream) *standard-output*)
1156        (T stream)))
1157
1158(defun do-xp-printing (fn stream args)
1159  (let ((xp (slot-value (get-pretty-print-stream stream) 'xp-structure))
1160        (*current-level* 0)
1161        (*xp-current-object* nil)
1162        (result nil))
1163    (declare (special *foo-string*))
1164    (catch 'line-limit-abbreviation-exit
1165      (start-block xp nil nil nil)
1166      (setq result (apply fn xp args))
1167      (end-block xp nil))
1168    (when (and *locating-circularities*
1169               (zerop *locating-circularities*) ;No circularities.
1170               ;(= (xp-line-no xp) 1)           ;Didn't suppress line.
1171               ;(zerop (xp-buffer-offset xp))
1172               )        ;Didn't suppress partial line.
1173      (setq *locating-circularities* nil)
1174      (let ((s (xp-string-stream xp)))
1175        (when s
1176          (stream-write-entire-string (xp-base-stream xp)
1177                                      (get-output-stream-string s)))))
1178    (when (catch 'line-limit-abbreviation-exit
1179            (attempt-to-output xp nil T)
1180            nil)
1181      (attempt-to-output xp T T))
1182    (free-pretty-print-stream xp)
1183    result))
1184
1185
1186
1187(defun write+ (object xp &optional interior-cdr circle)
1188  (let ((pretty *print-pretty*)) ;((*parents* *parents*))
1189    (when (or circle
1190              (not (and *circularity-hash-table*
1191                        (eq (setq circle (circularity-process xp object interior-cdr)) :subsequent))))
1192      (when *circularity-hash-table*
1193        (setq *xp-current-object* object))     
1194      (let ((printer (if pretty (get-printer object *print-pprint-dispatch*) nil))
1195            #|type|#)
1196        (cond (printer
1197               (funcall printer xp object))
1198              ((and pretty (maybe-print-fast xp object)))
1199              (t (write-not-pretty xp object
1200                                   (if *print-level*
1201                                     (- *print-level* *current-level*)
1202                                     most-positive-fixnum)
1203                                   interior-cdr circle)))))))
1204
1205;It is vital that this function be called EXACTLY once for each occurrence of
1206;  each thing in something being printed.
1207;Returns nil if printing should just continue on.
1208;  Either it is not a duplicate, or we are in the first pass and do not know.
1209;returns :FIRST if object is first occurrence of a DUPLICATE.
1210;  (This can only be returned on a second pass.)
1211;  After an initial code (printed by this routine on the second pass)
1212;  printing should continue on for the object.
1213;returns :SUBSEQUENT if second or later occurrence.
1214;  Printing is all taken care of by this routine.
1215
1216;Note many (maybe most) lisp implementations have characters and small numbers
1217;represented in a single word so that the are always eq when they are equal and the
1218;reader takes care of properly sharing them (just as it does with symbols).
1219;Therefore, we do not want circularity processing applied to them.  However,
1220;some kinds of numbers (e.g., bignums) undoubtedly are complex structures that
1221;the reader does not share.  However, they cannot have circular pointers in them
1222;and it is therefore probably a waste to do circularity checking on them.  In
1223;any case, it is not clear that it easy to tell exactly what kinds of numbers a
1224;given implementation of CL is going to have the reader automatically share.
1225
1226; if not pretty print a space before dot
1227
1228(defun circularity-process (xp object interior-cdr? &aux (not-pretty (not *print-pretty*)))
1229  (unless (or (numberp object)
1230              (characterp object)
1231              (and (symbolp object)     ;Reader takes care of sharing.
1232                   (or (null *print-gensym*) (symbol-package object))))
1233    (let ((id (gethash object *circularity-hash-table*)))
1234      (if (and *locating-circularities* *print-circle*) ; << was *locating-circularities*
1235        (progn ;(push (list object id info-p) barf)
1236          (cond ((null id)      ;never seen before
1237                 ;(when *parents* (push object *parents*))
1238                 (setf (gethash object *circularity-hash-table*) 0)
1239                 nil)
1240                ((zerop id) ;possible second occurrence
1241                 (setf (gethash object *circularity-hash-table*)
1242                       (incf *locating-circularities*))
1243                 :subsequent)
1244                (T :subsequent)));third or later occurrence
1245        (progn ;(push (list object id info-p interior-cdr?) barf2)         
1246          (cond 
1247           ((or (null id)       ;never seen before (note ~@* etc. conses)
1248                (zerop id));no duplicates
1249            nil)
1250           (t (when interior-cdr?
1251                (write-string++ (if not-pretty " . #" ". #")
1252                                            xp 0
1253                                            (if not-pretty 4 3)))
1254              (cond ((plusp id)
1255                     (cond (interior-cdr?
1256                            (decf *current-level*))
1257                           (T (write-char++ #\# xp)))
1258                     (print-fixnum xp id)
1259                     (write-char++ #\= xp)
1260                     (setf (gethash object *circularity-hash-table*) (- id))
1261                     :first)
1262                    (T (when (not interior-cdr?) (write-char++ #\# xp))
1263                       (print-fixnum xp (- id))
1264                       (write-char++ #\# xp)
1265                       :subsequent)))))))))
1266
1267;This prints a few very common, simple atoms very fast.
1268;Pragmatically, this turns out to be an enormous savings over going to the
1269;standard printer all the time.  There would be diminishing returns from making
1270;this work with more things, but might be worth it.
1271; does this really win?
1272
1273(defun maybe-print-fast (xp object)
1274  (cond ((stringp object)
1275         (cond ((null *print-escape*) (write-string+ object xp 0 (length object)) T)
1276               ((every #'(lambda (c) (not (or (eq c #\") (eq c #\\))))
1277                       object)
1278                (write-char++ #\" xp)
1279                (write-string+ object xp 0 (length object))
1280                (write-char++ #\" xp) T)))
1281        ((typep object 'fixnum)
1282         (when (and (null *print-radix*) (= *print-base* 10.))
1283           (when (minusp object)
1284             (write-char++ #\- xp)
1285             (setq object (- object)))
1286           (print-fixnum xp object) T))
1287        ((symbolp object)
1288         (if (> *print-base* 10) ; may need to escape potential numbers
1289           (write-a-symbol object (xp-stream xp))
1290           (let ((s (symbol-name object))
1291                 (p (symbol-package object))
1292                 (is-key (keywordp object))
1293                 (mode (case *print-case*
1294                         (:downcase :down)
1295                         (:capitalize :cap1)
1296                         (T nil)))) ; note no-escapes-needed requires all caps
1297             (declare (string s))
1298             (cond ((and (or is-key (eq p *package*)
1299                             (and  ;*package* ;can be NIL on symbolics
1300                              (multiple-value-bind (symbol type) (find-symbol s)
1301                                (and type (eq object symbol)))))
1302                         (eq (readtable-case *readtable*) :upcase)
1303                         (neq *print-case* :studly)
1304                         (no-escapes-needed s))
1305                    (when (and is-key *print-escape*)
1306                      (write-char++ #\: xp))
1307                    (if mode (push-char-mode xp mode))
1308                    (write-string++ s xp 0 (length s))
1309                    (if mode (pop-char-mode xp)) T)))))))
1310         
1311(defun print-fixnum (xp fixnum)
1312  (multiple-value-bind (digits d)
1313      (truncate fixnum 10)
1314    (unless (zerop digits)
1315      (print-fixnum xp digits))
1316    (write-char++ (code-char (+ #.(char-code #\0) d)) xp)))
1317
1318;just wants to succeed fast in a lot of common cases.
1319;assumes no funny readtable junk for the characters shown.
1320
1321(defun no-escapes-needed (s)
1322  (declare (string s))
1323  (let ((n (length s)))
1324    (declare (fixnum n))
1325    (and (not (zerop n))
1326         (let ((c (schar s 0)))
1327           (or (and (alpha-char-p c) (upper-case-p c)) (%str-member c "*<>")))
1328         (do ((i 1 (1+ i))) ((= i n) T)
1329           (declare (fixnum i))
1330           (let ((c (schar s i)))
1331             (if (not (or (digit-char-p c)
1332                          (and (alpha-char-p c) (upper-case-p c))
1333                          (%str-member c "*+<>-")))
1334                 (return nil)))))))
1335
1336
1337(defun pprint (object &optional (stream *standard-output*))
1338  "Prettily output OBJECT preceded by a newline."
1339  (setq stream (decode-stream-arg stream))
1340  (terpri stream)
1341  (let ((*print-escape* T) (*print-pretty* T))
1342    (write-1 object stream))
1343  (values))
1344
1345
1346;Any format string that is converted to a function is always printed
1347;via an XP stream (See formatter).
1348
1349(defvar *format-string-cache* nil)
1350
1351(defun process-format-string (string-or-fn force-fn?)
1352  (declare (ignore force-fn?))
1353  string-or-fn)
1354
1355
1356;Each of these causes the stream to be pessimistic and insert
1357;newlines wherever it might have to, when forcing the partial output
1358;out.  This is so that things will be in a consistent state if
1359;output continues to the stream later.
1360
1361(defmethod stream-force-output ((xp xp-structure))
1362  (attempt-to-output xp t t))
1363
1364(defmethod stream-finish-output ((xp xp-structure))
1365  (attempt-to-output xp t t))
1366
1367
1368;           ---- FUNCTIONAL INTERFACE TO DYNAMIC FORMATTING ----
1369
1370;The internal functions in this file, and the (formatter "...") expansions
1371;use the '+' forms of these functions directly (which is faster) because,
1372;they do not need error checking or fancy stream coercion.  The '++' forms
1373;additionally assume the thing being output does not contain a newline.
1374
1375
1376(defun pprint-newline (kind &optional (stream *standard-output*))
1377    "Output a conditional newline to STREAM (which defaults to
1378   *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do
1379   nothing if not. KIND can be one of:
1380     :LINEAR - A line break is inserted if and only if the immediatly
1381        containing section cannot be printed on one line.
1382     :MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
1383        (See *PRINT-MISER-WIDTH*.)
1384     :FILL - A line break is inserted if and only if either:
1385       (a) the following section cannot be printed on the end of the
1386           current line,
1387       (b) the preceding section was not printed on a single line, or
1388       (c) the immediately containing section cannot be printed on one
1389           line and miser-style is in effect.
1390     :MANDATORY - A line break is always inserted.
1391   When a line break is inserted by any type of conditional newline, any
1392   blanks that immediately precede the conditional newline are ommitted
1393   from the output and indentation is introduced at the beginning of the
1394   next line. (See PPRINT-INDENT.)"
1395    (when (not (memq kind '(:linear :miser :fill :mandatory)))
1396      (signal-type-error kind '(member :linear :miser :fill :mandatory) 
1397                         "Invalid KIND argument ~A to PPRINT-NEWLINE"))
1398    (when (and *print-pretty* *logical-block-p*)   
1399      (setq stream (decode-stream-arg stream))
1400      (cond ((xp-structure-p stream)
1401             (pprint-newline+ kind stream))
1402            ((typep stream 'xp-stream)
1403             (pprint-newline+ kind (slot-value stream 'xp-structure)))
1404            (t (pp-newline stream kind))))
1405    nil)
1406
1407(defun pprint-indent (relative-to n &optional (stream *standard-output*))
1408  "Specify the indentation to use in the current logical block if STREAM
1409   (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream
1410   and do nothing if not. (See PPRINT-LOGICAL-BLOCK.)  N is the indentation
1411   to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
1412     :BLOCK - Indent relative to the column the current logical block
1413        started on.
1414     :CURRENT - Indent relative to the current column.
1415   The new indentation value does not take effect until the following line
1416   break."
1417  (setq stream (decode-stream-arg stream))
1418  (when (not (memq relative-to '(:block :current)))
1419    (error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to))
1420  (cond ((xp-structure-p stream)
1421         (pprint-indent+ relative-to (truncate n) stream))
1422        ((typep stream 'xp-stream)
1423         (pprint-indent+ relative-to (truncate n) (slot-value stream 'xp-structure)))
1424        (t nil)) ; ???(break)))
1425  nil)
1426
1427(defun pprint-tab (kind colnum colinc &optional (stream *standard-output*))
1428  "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing
1429   stream, perform tabbing based on KIND, otherwise do nothing. KIND can
1430   be one of:
1431     :LINE - Tab to column COLNUM. If already past COLNUM tab to the next
1432       multiple of COLINC.
1433     :SECTION - Same as :LINE, but count from the start of the current
1434       section, not the start of the line.
1435     :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of
1436       COLINC.
1437     :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start
1438       of the current section, not the start of the line."
1439  (setq stream (decode-stream-arg stream))
1440  (when (not (memq kind '(:line :section :line-relative :section-relative)))
1441    (error "Invalid KIND argument ~A to PPRINT-TAB" kind))
1442
1443  (when (and *print-pretty* *logical-block-p*)
1444    (cond ((xp-structure-p stream)
1445           (pprint-tab+ kind colnum colinc stream))
1446          ((typep stream 'xp-stream)
1447           (pprint-tab+ kind colnum colinc (slot-value stream 'xp-structure)))))
1448  nil)
1449
1450;                        ---- COMPILED FORMAT ----
1451
1452;Note that compiled format strings always print through xp streams even if
1453;they don't have any xp directives in them.  As a result, the compiled code
1454;can depend on the fact that the stream being operated on is an xp
1455;stream not an ordinary one.
1456
1457
1458(eval-when (:compile-toplevel :load-toplevel :execute)
1459; called by formatter frobs
1460(defun do-sub-format-0 (s control-string args)
1461    (setq s (if (xp-structure-p s)(xp-stream s)
1462              (if (output-stream-p s)
1463                s
1464                (require-type s '(satisfies output-stream-p)))))
1465               
1466    (let ((*format-control-string* control-string)
1467          (*format-top-level* t))     
1468      (cond ((and (or *print-pretty* *print-circle*)
1469                  (not (typep s 'xp-stream)))
1470             (maybe-initiate-xp-printing
1471              #'do-sub-format-1 s args))
1472            (t (do-sub-format-1 s args)))))
1473
1474; called from above, format, and logical-block-sub
1475(defun do-sub-format-1 (stream args)
1476  (let ((*format-original-arguments* args)
1477        (*format-arguments* args)
1478        (*format-colon-rest* 'error))
1479    (declare (special *format-colon-rest*))
1480    (if (xp-structure-p stream)(setq stream (xp-stream stream)))
1481    (do-sub-format stream)
1482    ; copylist cause args is dynamic extent in format & formatter
1483    ; n.b. when printing lisp code its nearly always nil
1484    (setq args *format-arguments*)
1485    (if (and (consp args) *format-top-level*)(copy-list args) args)))
1486
1487(defmacro formatter (control-string) ; maybe-initiate-xp-printing?
1488  (setq control-string (require-type control-string 'string))
1489  `(function 
1490    (lambda (s &rest args)
1491      ; IFFY because things can end up in the same place on the stack
1492      ; appearing EQ giving bogus circularity detection
1493      ; But now we have fixed things so we don't circle check rest args (ha!)
1494      (do-sub-format-0 s ,control-string args))))
1495
1496(defmacro pprint-pop+ (args xp)
1497  `(if (pprint-pop-check+ ,args ,xp)
1498       (return-from logical-block nil)
1499       (pop ,args)))
1500
1501(defun pprint-pop-check+ (args xp)
1502  (let ((current-length *current-length*))
1503    (declare (fixnum current-length))
1504    (setq current-length (setq *current-length* (1+ *current-length*)))
1505    (cond ((not (listp args))  ;must be first so supersedes length abbrev
1506           (write-string++ ". " xp 0 2)
1507           (write+ args xp)
1508           T)
1509          ((and *print-length* ;must supersede circle check
1510                (not (< current-length *print-length*)))
1511           (write-string++ "..." xp 0 3)
1512           ;(setq *abbreviation-happened* T)
1513           T)
1514          ((and *circularity-hash-table* (not *format-top-level*)
1515                (not (zerop current-length)))
1516           (let ((circle (circularity-process xp args T)))
1517             (case circle
1518               (:first ;; note must inhibit rechecking of circularity for args.
1519                (write+ args xp T circle)
1520                T)
1521               (:subsequent T)
1522               (T nil)))))))
1523
1524(defun check-block-abbreviation (xp args circle-check?)
1525  (cond ((not (listp args)) (write+ args xp) T)
1526        ((and *print-level* (> *current-level* *print-level*))
1527         (write-char++ #\# XP) 
1528         ;(setq *abbreviation-happened* T)
1529         T)
1530        ((and *circularity-hash-table* circle-check? (neq args *xp-current-object*)
1531              (eq (circularity-process xp args nil) :subsequent))
1532         T)
1533        (T nil)))
1534
1535
1536)
1537
1538
1539;                ---- PRETTY PRINTING FORMATS ----
1540
1541(defun pretty-array (xp array)
1542  (when (typep xp 'xp-stream)(setq xp (slot-value xp 'xp-structure)))
1543  (cond ((vectorp array) (pretty-vector xp array))
1544        ((zerop (array-rank array))
1545         (write-string++ "#0A" xp 0 3)
1546         (write+ (aref array) xp))
1547        (T (pretty-non-vector xp array))))
1548
1549(defun pretty-vector (xp v)
1550  (pprint-logical-block (xp nil :prefix "#(" :suffix ")")
1551    (let ((end (length v)) (i 0))
1552      (declare (fixnum end i))
1553      (when (plusp end)
1554        (loop (pprint-pop)   ;HUH
1555              (write+ (aref v i) xp)
1556              (if (= (incf i) end) (return nil))
1557              (write-char++ #\space xp)
1558              (pprint-newline+ :fill xp))))))
1559
1560(defun pretty-non-vector (xp array)
1561  (let* ((bottom (1- (array-rank array)))
1562         (indices (make-list (1+ bottom) :initial-element 0))
1563         (dims (array-dimensions array)))
1564    (funcall (formatter "#~DA") xp (1+ bottom))
1565    (labels ((pretty-slice (slice)
1566               (pprint-logical-block (xp nil :prefix "(" :suffix ")")
1567                 (let ((end (nth slice dims))
1568                       (spot (nthcdr slice indices))
1569                       (i 0))
1570                   (when (plusp end)
1571                     (loop (pprint-pop)
1572                           (setf (car spot) i)
1573                           (if (= slice bottom)
1574                               (write+ (apply #'aref array indices) xp)
1575                               (pretty-slice (1+ slice)))
1576                           (if (= (incf i) end) (return nil))
1577                           (write-char++ #\space xp)
1578                           (pprint-newline+ (if (= slice bottom) :fill :linear) xp)))))))
1579      (pretty-slice 0))))
1580
1581(defun pretty-structure (xp struc &aux (class (struct-def struc)) (slots (sd-slots class)))
1582  (when (typep xp 'xp-stream)(setq xp (slot-value xp 'xp-structure)))
1583  (let* ((class (ccl::struct-def struc)) ;;guaranteed non-NIL if this function is called
1584         (pf (structure-print-function class)))
1585    (cond 
1586     (pf
1587      (if (consp pf)
1588        (funcall (car pf) struc (xp-stream xp))
1589        (funcall pf struc (xp-stream xp) *current-level*)))
1590     (t 
1591      (pprint-logical-block (xp nil :prefix "#S(" :suffix ")")
1592        (pprint-pop)
1593        (write+ (sd-name class) xp)
1594        (start-block xp (if (cdr slots) " " "") nil "")
1595        (when slots
1596          (let ((pcase *print-case*))
1597            (loop 
1598              (let* ((slot (pop slots))(name (ssd-name slot)))
1599                (cond
1600                 ((symbolp name)
1601                  (pprint-pop)
1602                  (write-char++ #\: xp)
1603                  (write-pname (symbol-name name) pcase xp)
1604                  (write-char++ #\space xp)
1605                  (pprint-pop)
1606                  (write+ (uvref struc (ssd-offset slot)) xp)             
1607                  (when (null slots)(return nil))
1608                  (write-char++ #\space xp)
1609                  (pprint-newline+ :fill xp))
1610                 ((null slots)(return nil)))))))
1611        (end-block xp ""))))))
1612
1613
1614
1615;Must use pprint-logical-block (no +) in the following three, because they are
1616;exported functions.
1617
1618(defun pprint-linear (s list &optional (colon? T) atsign?)
1619  "Output LIST to STREAM putting :LINEAR conditional newlines between each
1620   element. If COLON? is NIL (defaults to T), then no parens are printed
1621   around the output. ATSIGN? is ignored (but allowed so that PPRINT-LINEAR
1622   can be used with the ~/.../ format directive."
1623  (declare (ignore atsign?))
1624  (pprint-logical-block (s list :prefix (if colon? "(" "")
1625                                :suffix (if colon? ")" ""))
1626    (pprint-exit-if-list-exhausted)
1627    (loop (write+ (pprint-pop) s)
1628          (pprint-exit-if-list-exhausted)
1629          (write-char++ #\space s)
1630          (pprint-newline+ :linear s))))
1631
1632(defun pprint-fill (s list &optional (colon? T) atsign?)
1633  "Output LIST to STREAM putting :FILL conditional newlines between each
1634   element. If COLON? is NIL (defaults to T), then no parens are printed
1635   around the output. ATSIGN? is ignored (but allowed so that PPRINT-FILL
1636   can be used with the ~/.../ format directive."
1637  (declare (ignore atsign?))
1638  (pprint-logical-block (s list :prefix (if colon? "(" "")
1639                                :suffix (if colon? ")" ""))
1640    (pprint-exit-if-list-exhausted)
1641    (loop (write+ (pprint-pop) s)
1642          (pprint-exit-if-list-exhausted)
1643          (write-char++ #\space s)
1644          (pprint-newline+ :fill s))))
1645
1646(defun pprint-tabular (s list &optional (colon? T) atsign? (tabsize nil))
1647  "Output LIST to STREAM tabbing to the next column that is an even multiple
1648   of TABSIZE (which defaults to 16) between each element. :FILL style
1649   conditional newlines are also output between each element. If COLON? is
1650   NIL (defaults to T), then no parens are printed around the output.
1651   ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with
1652   the ~/.../ format directive."
1653  (declare (ignore atsign?))
1654  (when (null tabsize) (setq tabsize 16))
1655  (pprint-logical-block (s list :prefix (if colon? "(" "")
1656                                :suffix (if colon? ")" ""))   
1657    (pprint-exit-if-list-exhausted)
1658    (loop (write+ (pprint-pop) s)
1659          (pprint-exit-if-list-exhausted)
1660          (write-char++ #\space s)
1661          (pprint-tab+ :section-relative 0 tabsize s)
1662          (pprint-newline+ :fill s))))
1663
1664; perhaps should use alternate-fn-call instead
1665(defun fn-call (xp list)
1666  (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list))
1667
1668;Although idiosyncratic, I have found this very useful to avoid large
1669;indentations when printing out code.
1670
1671(defun alternative-fn-call (xp list)
1672  (if (> (length (symbol-name (car list))) 12)
1673      (funcall (formatter "~:<~1I~@{~W~^ ~_~}~:>") xp list)
1674      (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list)))
1675
1676(defun bind-list (xp list &rest args)
1677  (declare (ignore args))
1678  (if (do ((i 50 (1- i))
1679           (ls list (cdr ls))) ((null ls) t)
1680        (when (or (not (consp ls)) (not (symbolp (car ls))) (minusp i))
1681          (return nil)))
1682      (pprint-fill xp list)
1683      (funcall (formatter "~:<~@{~:/pprint-fill/~^ ~_~}~:>") xp list)))
1684
1685(defun block-like (xp list &rest args)
1686    (declare (ignore args))
1687  (funcall (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>") xp list))
1688
1689(defun defun-like (xp list &rest args)
1690    (declare (ignore args))
1691  (funcall (formatter "~:<~1I~W~^ ~@_~W~^ ~@_~:/pprint-fill/~^~@{ ~_~W~^~}~:>")
1692            xp list))
1693
1694(defun print-fancy-fn-call (xp list template)
1695  (let ((i 0) (in-first-section T))
1696    (declare (fixnum i))
1697    (pprint-logical-block+ (xp list "(" ")" nil T nil)
1698      (write+ (pprint-pop) xp)
1699      (pprint-indent+ :current 1 xp)
1700      (loop
1701        (pprint-exit-if-list-exhausted)
1702        (write-char++ #\space xp)
1703        (when (eq i (car template))
1704          (pprint-indent+ :block (cadr template) xp)
1705          (setq template (cddr template))
1706          (setq in-first-section nil))
1707        (pprint-newline (cond ((and (zerop i) in-first-section) :miser)
1708                              (in-first-section :fill)
1709                              (T :linear))
1710                        xp)
1711        (write+ (pprint-pop) xp)
1712        (incf i)))))
1713
1714(defun defmethod-like (xp list &rest args)
1715  (declare (ignore args))
1716  (cond ((and (consp (cdr list))(consp (cddr list))(listp (caddr list)))
1717         (defun-like xp list))
1718        (t (defsetf-print xp list))))
1719
1720
1721(defun maybelab (xp item &rest args)
1722    (declare (ignore args) (special need-newline indentation))
1723  (when (typep xp 'xp-stream)(setq xp (slot-value xp 'xp-structure)))
1724  (when need-newline (pprint-newline+ :mandatory xp))
1725  (cond ((and item (symbolp item))
1726         (write+ item xp)
1727         (setq need-newline nil))
1728        (T (pprint-tab+ :section indentation 0 xp)
1729           (write+ item xp)
1730           (setq need-newline T))))
1731
1732(defun function-call-p (x)
1733  (and (consp x) (symbolp (car x)) (fboundp (car x))))
1734
1735
1736
1737;THE FOLLOWING STUFF SETS UP THE DEFAULT *PRINT-PPRINT-DISPATCH*
1738 
1739;This is an attempt to specify a correct format for every form in the CL book
1740;that does not just get printed out like an ordinary function call
1741;(i.e., most special forms and many macros).  This of course does not
1742;cover anything new you define.
1743
1744(defun let-print (xp obj)
1745  (funcall (formatter "~:<~1I~W~^ ~@_~/ccl::bind-list/~^~@{ ~_~W~^~}~:>") xp obj))
1746
1747(defun cond-print (xp obj)
1748  (funcall (formatter "~:<~W~^ ~:I~@_~@{~:/pprint-linear/~^ ~_~}~:>") xp obj))
1749
1750(defun dmm-print (xp list)
1751  (print-fancy-fn-call xp list '(3 1)))
1752
1753(defun defsetf-print (xp list)
1754  (print-fancy-fn-call xp list '(3 1)))
1755
1756(defun do-print (xp obj)
1757  (funcall 
1758 (formatter "~:<~W~^ ~:I~@_~/ccl::bind-list/~^ ~_~:/pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>")
1759           xp obj))
1760
1761
1762(defun flet-print (xp obj)
1763  (funcall (formatter "~:<~1I~W~^ ~@_~:<~@{~/ccl::block-like/~^ ~_~}~:>~^~@{ ~_~W~^~}~:>")
1764           xp obj))
1765
1766(defun function-print (xp list)
1767  (if (and *print-abbreviate-quote* (consp (cdr list)) (null (cddr list)))
1768      (format (xp-stream xp) "#'~W" (cadr list))
1769      (fn-call xp list)))
1770
1771(defun mvb-print (xp list)
1772  (print-fancy-fn-call xp list '(1 3 2 1)))
1773
1774(defun prog-print (xp list)
1775  (let ((need-newline T) (indentation (1+ (length (symbol-name (car list)))))) ; less?
1776    (declare (special need-newline indentation))
1777    (funcall (formatter "~:<~W~^ ~:/pprint-fill/~^ ~@{~/ccl::maybelab/~^ ~}~:>")
1778             xp list)))
1779
1780
1781(defun progn-print (xp list)
1782  (funcall (formatter "~:<~1I~@{~W~^ ~_~}~:>") xp list))
1783
1784(defun setq-print (xp obj)
1785  (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>") xp obj))
1786
1787(defun quote-print (xp list)
1788  (if (and (consp (cdr list)) (null (cddr list)))
1789      (format (xp-stream xp) "'~W" (cadr list))
1790      (pprint-fill xp list)))
1791
1792(defun tagbody-print (xp list)
1793  (let ((need-newline (and (consp (cdr list))
1794                           (symbolp (cadr list)) (cadr list)))
1795        (indentation (1+ (length (symbol-name (car list))))))
1796    (declare (special need-newline indentation))
1797    (funcall (formatter "~:<~W~^ ~@{~/ccl::maybelab/~^ ~}~:>") xp list)))
1798
1799(defun up-print (xp list)
1800  (print-fancy-fn-call xp list '(0 3 1 1)))
1801
1802;here is some simple stuff for printing LOOP
1803
1804;The challange here is that we have to effectively parse the clauses of the
1805;loop in order to know how to print things.  Also you want to do this in a
1806;purely incremental way so that all of the abbreviation things work, and
1807;you wont blow up on circular lists or the like.  (More aesthic output could
1808;be produced by really parsing the clauses into nested lists before printing them.)
1809
1810;The following program assumes the following simplified grammar of the loop
1811;clauses that explains how to print them.  Note that it does not bare much
1812;resemblence to the right parsing grammar, however, it produces half decent
1813;output.  The way to make the output better is to make the grammar more
1814;detailed. 
1815;
1816;loop == (LOOP {clause}*)      ;one clause on each line.
1817;clause == block | linear | cond | finally
1818;block == block-head {expr}*   ;as many exprs as possible on each line.
1819;linear == linear-head {expr}* ;one expr on each line.
1820;finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line.
1821;cond == cond-head [expr]
1822;          clause
1823;          {AND clause}*       ;one AND on each line.
1824;        [ELSE
1825;          clause
1826;          {AND clause}*]      ;one AND on each line.
1827;        [END]
1828;block-head == FOR | AS | WITH | AND
1829;              | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN
1830;              | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT
1831;              | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING
1832;linear-head == DO | DOING | INITIALLY
1833;var-head == FOR | AS | WITH
1834;cond-head == IF | WHEN | UNLESS
1835;expr == <anything that is not a head symbol>
1836
1837;Note all the string comparisons below are required to support some
1838;existing implementations of LOOP.
1839(defun token-type (token &aux string)
1840  (cond ((not (symbolp token)) :expr)
1841        ((string= (setq string (string token)) "FINALLY") :finally)
1842        ((member string '("IF" "WHEN" "UNLESS") :test #'string=) :cond-head)
1843        ((member string '("DO" "DOING" "INITIALLY") :test #'string=) :linear-head)
1844        ((member string '("FOR" "AS" "WITH" "AND" "END" "ELSE"
1845                          "REPEAT" "NAMED" "WHILE" "UNTIL" "ALWAYS" "NEVER"
1846                          "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND"
1847                          "APPENDING" "NCONC" "NCONCING" "COUNT" "COUNTING"
1848                          "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING"
1849                          "MINIMIZE" "MINIMIZING")
1850                 :test #'string=)
1851         :block-head)
1852        (T :expr)))
1853
1854; maybe put in a separate file (replace write-char by write-char+)
1855(defun pretty-loop (xp loop)
1856  (if (not (and (consp (cdr loop)) (symbolp (cadr loop)))) ; old-style loop
1857      (tagbody-print xp loop)
1858      (pprint-logical-block (xp loop :prefix "(" :suffix ")")
1859        (let (token type)
1860          (labels ((next-token ()
1861                     (pprint-exit-if-list-exhausted)
1862                     (setq token (pprint-pop))
1863                     (setq type (token-type token)))
1864                   (print-clause (xp)
1865                     (case type
1866                       (:linear-head (print-exprs xp nil :mandatory))
1867                       (:cond-head (print-cond xp))
1868                       (:finally (print-exprs xp T :mandatory))
1869                       (otherwise (print-exprs xp nil :fill))))
1870                   (print-exprs (xp skip-first-non-expr newline-type)
1871                     (pprint-logical-block (xp nil)
1872                       (write+ token xp)
1873                       (next-token)
1874                       (when (and skip-first-non-expr (not (eq type :expr)))
1875                         (write-char+ #\space xp)
1876                         (write+ token xp)
1877                         (next-token))
1878                       (when (eq type :expr)
1879                         (write-char+ #\space xp)
1880                         (pprint-indent :current 0 xp)
1881                         (loop (write+ token xp)
1882                               (next-token)
1883                               (when (not (eq type :expr)) (return nil))
1884                               (write-char+ #\space xp)
1885                               (pprint-newline newline-type xp)))))
1886                   (print-cond (xp)
1887                     (pprint-logical-block (xp nil)
1888                       (write+ token xp)
1889                       (next-token)
1890                       (when (eq type :expr)
1891                         (write-char+ #\space xp)
1892                         (write+ token xp)
1893                         (next-token))
1894                       (write-char+ #\space xp)
1895                       (pprint-indent :block 2 xp)
1896                       (pprint-newline :linear xp)
1897                       (print-clause xp)
1898                       (print-and-list xp)
1899                       (when (string= (string token) "ELSE")
1900                         (print-else-or-end xp)
1901                         (write-char+ #\space xp)
1902                         (pprint-newline :linear xp)
1903                         (print-clause xp)
1904                         (print-and-list xp))
1905                       (when (string= (string token) "END")
1906                         (print-else-or-end xp))))
1907                   (print-and-list (xp)
1908                     (loop (when (not (string= (string token) "AND")) (return nil))
1909                           (write-char+ #\space xp)
1910                           (pprint-newline :mandatory xp)
1911                           (write+ token xp)
1912                           (next-token)
1913                           (write-char+ #\space xp)
1914                           (print-clause xp)))
1915                   (print-else-or-end (xp)
1916                     (write-char+ #\space xp)
1917                     (pprint-indent :block 0 xp)
1918                     (pprint-newline :linear xp)
1919                     (write+ token xp)
1920                     (next-token)
1921                     (pprint-indent :block 2 xp)))
1922            (pprint-exit-if-list-exhausted)
1923            (write+ (pprint-pop) xp)
1924            (next-token)
1925            (write-char+ #\space xp)
1926            (pprint-indent :current 0 xp)
1927            (loop (print-clause xp)
1928                  (write-char+ #\space xp)
1929                  (pprint-newline :linear xp)
1930                  ; without this we can loop forever
1931                  (if (and *print-level*
1932                           (>= *current-level* *print-level*))
1933                    (return))))))))
1934
1935;Backquote is a big problem we MUST do all this reconsing of structure in
1936;order to get a list that will trigger the right formatting functions to
1937;operate on it.  On the other side of the coin, we must use a non-list structure
1938;for the little backquote printing markers to ensure that they will always
1939;print out the way we want no matter what the code printers say.
1940;  Note that since it is sometimes possible to write the same
1941;backquote form in several ways, this might not necessarily print out a
1942;form in exactly the way you wrote it.  For example '`(a .,b) and '`(a ,@b)
1943;both print out as `'(a .,b), because the backquote reader produces the
1944;same code in both cases.
1945
1946
1947(setq *IPD* (make-pprint-dispatch-table))
1948
1949(set-pprint-dispatch+ '(satisfies function-call-p) #'alternative-fn-call '(-5) *IPD*)
1950(set-pprint-dispatch+ 'cons #'pprint-fill '(-10) *IPD*)
1951
1952(set-pprint-dispatch+ '(cons (member defstruct)) #'block-like '(0) *IPD*)
1953(set-pprint-dispatch+ '(cons (member block)) #'block-like '(0) *IPD*) 
1954(set-pprint-dispatch+ '(cons (member case)) #'block-like '(0) *IPD*) 
1955(set-pprint-dispatch+ '(cons (member catch)) #'block-like '(0) *IPD*) 
1956(set-pprint-dispatch+ '(cons (member ccase)) #'block-like '(0) *IPD*) 
1957(set-pprint-dispatch+ '(cons (member compiler-let)) #'let-print '(0) *IPD*)
1958(set-pprint-dispatch+ '(cons (member cond)) #'cond-print '(0) *IPD*)
1959(set-pprint-dispatch+ '(cons (member ctypecase)) #'block-like '(0) *IPD*)
1960(set-pprint-dispatch+ '(cons (member defclass)) #'defun-like '(0) *IPD*)
1961(set-pprint-dispatch+ '(cons (member ctypecase)) #'block-like '(0) *IPD*) 
1962(set-pprint-dispatch+ '(cons (member defconstant)) #'defun-like '(0) *IPD*)
1963(set-pprint-dispatch+ '(cons (member define-setf-expander)) #'defun-like '(0) *IPD*) 
1964(set-pprint-dispatch+ '(cons (member defmacro)) #'defun-like '(0) *IPD*) 
1965(set-pprint-dispatch+ '(cons (member define-modify-macro)) #'dmm-print '(0) *IPD*)
1966(set-pprint-dispatch+ '(cons (member defparameter)) #'defun-like '(0) *IPD*) 
1967(set-pprint-dispatch+ '(cons (member defsetf)) #'defsetf-print '(0) *IPD*)
1968(set-pprint-dispatch+ '(cons (member define-setf-expander)) #'defun-like '(0) *IPD*) 
1969(set-pprint-dispatch+ '(cons (member cl:defstruct)) #'block-like '(0) *IPD*) 
1970(set-pprint-dispatch+ '(cons (member deftype)) #'defun-like '(0) *IPD*) 
1971(set-pprint-dispatch+ '(cons (member defun)) #'defun-like '(0) *IPD*) 
1972(set-pprint-dispatch+ '(cons (member defmethod)) #'defmethod-like '(0) *IPD*) 
1973(set-pprint-dispatch+ '(cons (member defvar)) #'defun-like '(0) *IPD*) 
1974(set-pprint-dispatch+ '(cons (member do)) #'do-print '(0) *IPD*)
1975(set-pprint-dispatch+ '(cons (member do*)) #'do-print '(0) *IPD*) 
1976(set-pprint-dispatch+ '(cons (member do-all-symbols)) #'block-like '(0) *IPD*) 
1977(set-pprint-dispatch+ '(cons (member do-external-symbols)) #'block-like '(0) *IPD*) 
1978(set-pprint-dispatch+ '(cons (member do-symbols)) #'block-like '(0) *IPD*) 
1979(set-pprint-dispatch+ '(cons (member dolist)) #'block-like '(0) *IPD*) 
1980(set-pprint-dispatch+ '(cons (member dotimes)) #'block-like '(0) *IPD*) 
1981(set-pprint-dispatch+ '(cons (member ecase)) #'block-like '(0) *IPD*) 
1982(set-pprint-dispatch+ '(cons (member etypecase)) #'block-like '(0) *IPD*) 
1983(set-pprint-dispatch+ '(cons (member eval-when)) #'block-like '(0) *IPD*) 
1984(set-pprint-dispatch+ '(cons (member flet)) #'flet-print '(0) *IPD*)
1985(set-pprint-dispatch+ '(cons (member function)) #'function-print '(0) *IPD*)
1986(set-pprint-dispatch+ '(cons (member generic-function)) #'fn-call '(0) *IPD*)
1987(set-pprint-dispatch+ '(cons (member labels)) #'flet-print '(0) *IPD*) 
1988(set-pprint-dispatch+ '(cons (member lambda)) #'block-like '(0) *IPD*) 
1989(set-pprint-dispatch+ '(cons (member let)) #'let-print '(0) *IPD*)
1990(set-pprint-dispatch+ '(cons (member let*)) #'let-print '(0) *IPD*)
1991(set-pprint-dispatch+ '(cons (member locally)) #'block-like '(0) *IPD*)
1992
1993(set-pprint-dispatch+ '(cons (member loop)) #'pretty-loop '(0) *IPD*)
1994(set-pprint-dispatch+ '(cons (member macrolet)) #'flet-print '(0) *IPD*) 
1995(set-pprint-dispatch+ '(cons (member multiple-value-bind)) #'mvb-print '(0) *IPD*)
1996(set-pprint-dispatch+ '(cons (member multiple-value-setq)) #'block-like '(0) *IPD*) 
1997(set-pprint-dispatch+ '(cons (member prog)) #'prog-print '(0) *IPD*)
1998(set-pprint-dispatch+ '(cons (member prog*)) #'prog-print '(0) *IPD*)
1999(set-pprint-dispatch+ '(cons (member progv)) #'defun-like '(0) *IPD*)
2000(set-pprint-dispatch+ '(cons (member psetf)) #'setq-print '(0) *IPD*)
2001(set-pprint-dispatch+ '(cons (member psetq)) #'setq-print '(0) *IPD*)
2002(set-pprint-dispatch+ '(cons (member quote)) #'quote-print '(0) *IPD*)
2003(set-pprint-dispatch+ '(cons (member return-from)) #'block-like '(0) *IPD*)
2004(set-pprint-dispatch+ '(cons (member setf)) #'setq-print '(0) *IPD*)
2005(set-pprint-dispatch+ '(cons (member setq)) #'setq-print '(0) *IPD*)
2006(set-pprint-dispatch+ '(cons (member tagbody)) #'tagbody-print '(0) *IPD*)
2007(set-pprint-dispatch+ '(cons (member throw)) #'block-like '(0) *IPD*) 
2008(set-pprint-dispatch+ '(cons (member typecase)) #'block-like '(0) *IPD*) 
2009(set-pprint-dispatch+ '(cons (member unless)) #'block-like '(0) *IPD*) 
2010(set-pprint-dispatch+ '(cons (member unwind-protect)) #'up-print '(0) *IPD*)
2011(set-pprint-dispatch+ '(cons (member when)) #'block-like '(0) *IPD*) 
2012(set-pprint-dispatch+ '(cons (member with-input-from-string)) #'block-like '(0) *IPD*) 
2013(set-pprint-dispatch+ '(cons (member with-open-file)) #'block-like '(0) *IPD*)
2014(set-pprint-dispatch+ '(cons (member with-open-stream)) #'block-like '(0) *IPD*) 
2015(set-pprint-dispatch+ '(cons (member with-output-to-string)) #'block-like '(0) *IPD*) 
2016
2017
2018;so only happens first time is loaded. - why doesn't this work right?
2019; cause we have *print-pprin... bound to NIL
2020(when  t ;(eq *print-pprint-dispatch* T)
2021  (setq *print-pprint-dispatch* (copy-pprint-dispatch nil)))
2022
2023(setq *error-print-circle* t)  ; now we can circle-print
2024
2025; 82 bytes shorter but uglier
2026(defun write-not-pretty (stream object level list-kludge circle)
2027  (declare (type fixnum level) (type (or null fixnum) list-kludge))
2028  (when (xp-structure-p stream)(setq stream (xp-stream stream))) 
2029  (cond ((eq circle :subsequent)
2030         (if  list-kludge (stream-write-char stream #\)))
2031         (return-from write-not-pretty nil))
2032        ((not list-kludge))
2033        ((null object)(return-from write-not-pretty nil))
2034        ((not (consp object))
2035         (stream-write-entire-string stream " . "))
2036        ((eq circle :first)
2037         (stream-write-char stream #\()       
2038         (write-a-frob object stream level list-kludge)
2039         (stream-write-char stream #\))
2040         (return-from write-not-pretty nil))                     
2041        (t (stream-write-char stream #\space)))
2042  (write-a-frob object stream level list-kludge))
2043
2044(eval-when (:load-toplevel :execute) 
2045  (setq *error-print-circle* t))
2046
2047;changes since last documentation.
2048;~/fn/ only refers to global function values, not lexical.
2049
2050;------------------------------------------------------------------------
2051
2052;Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge,
2053;Massachusetts.
2054
2055;Permission to use, copy, modify, and distribute this software and its
2056;documentation for any purpose and without fee is hereby granted,
2057;provided that this copyright and permission notice appear in all
2058;copies and supporting documentation, and that the name of M.I.T. not
2059;be used in advertising or publicity pertaining to distribution of the
2060;software without specific, written prior permission. M.I.T. makes no
2061;representations about the suitability of this software for any
2062;purpose.  It is provided "as is" without express or implied warranty.
2063
2064;    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
2065;    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
2066;    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
2067;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
2068;    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
2069;    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
2070;    SOFTWARE.
2071
2072;------------------------------------------------------------------------
2073
2074#|
2075        Change History (most recent last):
2076        2       12/29/94        akh     merge with d13
2077|# ;(do not edit past this line!!)
Note: See TracBrowser for help on using the repository browser.