source: branches/working-0711/ccl/lib/pprint.lisp @ 9116

Last change on this file since 9116 was 9116, checked in by gz, 12 years ago

pretty-array: do not add a space in 0-rank arrays

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 85.6 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 (char buffer out-point)
1033           (do ((i (%i- out-point 1) (%i- i 1)))
1034               (nil)
1035             (cond ((%i< i 0)(return nil))
1036                   ((neq (schar buffer i) char)
1037                    (return i))))))
1038    (let* ((queue (xp-queue xp))
1039           (out-point (BP<-TP xp (xpq-pos queue Qentry)))
1040           (last-non-blank (find-not-char-reverse #\space (xp-buffer xp) out-point))
1041           (end (cond ((memq (xpq-kind queue Qentry) '(:fresh :unconditional)) out-point)
1042                      (last-non-blank (%i+ 1 last-non-blank))
1043                      (T 0)))
1044           (line-limit-exit (and (xp-line-limit xp) (not (%i> (xp-line-limit xp) (xp-line-no xp))))))
1045      (when line-limit-exit
1046        (setf (xp-buffer-ptr xp) end)          ;truncate pending output.
1047        (write-string+++ " .." xp 0 3)
1048        (reverse-string-in-place (xp-suffix xp) 0 (suffix-ptr xp))
1049        (write-string+++ (xp-suffix xp) xp 0 (suffix-ptr xp))
1050        (setf (xp-qleft xp) (qnext (xp-qright xp)))
1051        ;(setq *abbreviation-happened* '*print-lines*)
1052        (throw 'line-limit-abbreviation-exit T))
1053      (setf (xp-line-no xp)(%i+ 1 (xp-line-no xp)))
1054      (let ((bstream (xp-out-stream xp)))
1055        (when bstream
1056          (write-string (xp-buffer xp) bstream :start 0 :end end)
1057          (stream-write-char bstream #\newline))))))
1058
1059(defun setup-for-next-line (xp Qentry)
1060  (let* ((queue (xp-queue xp))
1061         (out-point (BP<-TP xp (xpq-pos queue Qentry)))
1062         (prefix-end
1063          (cond ((memq (xpq-kind queue Qentry) '(:unconditional :fresh))
1064                 (non-blank-prefix-ptr xp))
1065                (T (prefix-ptr xp))))
1066         (change (- prefix-end out-point)))
1067    (declare (fixnum out-point prefix-end change))
1068    (setf (xp-charpos xp) 0)
1069    (when (plusp change)                  ;almost never happens
1070      (xp-check-size (xp-buffer xp) (%i+ (xp-buffer-ptr xp) change)
1071                     #.buffer-min-size #.buffer-entry-size))
1072    (let ((buffer (xp-buffer xp)))
1073      (replace buffer buffer :start1 prefix-end
1074               :start2 out-point :end2 (xp-buffer-ptr xp))
1075      (replace buffer (xp-prefix xp) :end2 prefix-end)
1076      (setf (xp-buffer-ptr xp) (%i+ (xp-buffer-ptr xp) change))
1077      (setf (xp-buffer-offset xp) (%i- (xp-buffer-offset xp) change))
1078      (when (not (memq (xpq-kind queue Qentry) '(:unconditional :fresh)))
1079        (setf (section-start-line xp) (xp-line-no xp))))))
1080
1081(defun set-indentation-prefix (xp new-position)
1082  (let ((new-ind (max (non-blank-prefix-ptr xp) new-position)))
1083    (declare (fixnum new-ind))
1084    (setf (prefix-ptr xp) (initial-prefix-ptr xp))
1085    (xp-check-size (xp-prefix xp) new-ind #.prefix-min-size #.prefix-entry-size)
1086    (when (%i> new-ind (prefix-ptr xp))
1087      (fill (xp-prefix xp) #\space :start (prefix-ptr xp) :end new-ind))
1088    (setf (prefix-ptr xp) new-ind)))
1089
1090(defun set-prefix (xp prefix-string)
1091  (declare (string prefix-string))
1092  (replace (xp-prefix xp) prefix-string
1093           :start1 (%i- (prefix-ptr xp) (length prefix-string)))
1094  (setf (non-blank-prefix-ptr xp) (prefix-ptr xp)))
1095
1096(defun set-suffix (xp suffix-string)
1097  (declare (string suffix-string))
1098  (let* ((end (length suffix-string))
1099         (new-end (%i+ (suffix-ptr xp) end)))
1100    (declare (fixnum end new-end))
1101    (xp-check-size (xp-suffix xp) new-end #.suffix-min-size #.suffix-entry-size)
1102    (do ((i (1- new-end) (1- i)) (j 0 (1+ j))) ((= j end))
1103      (declare (fixnum i j))
1104      (setf (char (xp-suffix xp) i) (char suffix-string j)))
1105    (setf (suffix-ptr xp) new-end)))
1106
1107(defun reverse-string-in-place (string start end)
1108  (declare (fixnum start end))
1109  (do ((i start (1+ i)) (j (1- end) (1- j))) ((not (< i j)) string)
1110    (declare (fixnum i j))
1111    (let ((c (schar string i)))
1112      (setf (schar string i) (schar string j))
1113      (setf (schar string j) c))))
1114
1115;                  ---- BASIC INTERFACE FUNCTIONS ----
1116
1117;The internal functions in this file, and the (formatter "...") expansions
1118;use the '+' forms of these functions directly (which is faster) because,
1119;they do not need error checking of fancy stream coercion.  The '++' forms
1120;additionally assume the thing being output does not contain a newline.
1121
1122(defun maybe-initiate-xp-printing (fn stream &rest args)
1123  (if (xp-structure-p stream) (apply fn stream args)
1124    (if (typep stream 'xp-stream)
1125      (apply fn (slot-value stream 'xp-structure) args)
1126      (let ((*locating-circularities* (if *print-circle* 0 nil))
1127            (*circularity-hash-table*
1128             (if *print-circle* (get-circularity-hash-table) nil)))
1129        (prog1 (xp-print fn (decode-stream-arg stream) args)
1130          (if *circularity-hash-table*
1131            (free-circularity-hash-table *circularity-hash-table*)))))))
1132
1133(defun xp-print (fn stream args)
1134  (flet ((do-it (fn stream args)
1135           (prog1 (do-xp-printing fn stream args)
1136             (when *locating-circularities*
1137               (setq *locating-circularities* nil)
1138               (do-xp-printing fn stream args)))))
1139    (cond (*print-readably*
1140           (let* ((*print-level* nil)
1141                  (*print-length* nil)
1142                  (*print-lines* nil)
1143                  (*print-escape* t)
1144                  (*print-gensym* t)
1145                  (*print-array* nil))
1146             (do-it fn stream args)))
1147          (t (do-it fn stream args)))))
1148
1149(defun decode-stream-arg (stream)
1150  (cond ((eq stream T) *terminal-io*)
1151        ((null stream) *standard-output*)
1152        (T stream)))
1153
1154(defun do-xp-printing (fn stream args)
1155  (let ((xp (slot-value (get-pretty-print-stream stream) 'xp-structure))
1156        (*current-level* 0)
1157        (*xp-current-object* nil)
1158        (result nil))
1159    (declare (special *foo-string*))
1160    (catch 'line-limit-abbreviation-exit
1161      (start-block xp nil nil nil)
1162      (setq result (apply fn xp args))
1163      (end-block xp nil))
1164    (when (and *locating-circularities*
1165               (zerop *locating-circularities*) ;No circularities.
1166               ;(= (xp-line-no xp) 1)           ;Didn't suppress line.
1167               ;(zerop (xp-buffer-offset xp))
1168               )        ;Didn't suppress partial line.
1169      (setq *locating-circularities* nil)
1170      (let ((s (xp-string-stream xp)))
1171        (when s
1172          (stream-write-entire-string (xp-base-stream xp)
1173                                      (get-output-stream-string s)))))
1174    (when (catch 'line-limit-abbreviation-exit
1175            (attempt-to-output xp nil T)
1176            nil)
1177      (attempt-to-output xp T T))
1178    (free-pretty-print-stream xp)
1179    result))
1180
1181
1182
1183(defun write+ (object xp &optional interior-cdr circle)
1184  (let ((pretty *print-pretty*)) ;((*parents* *parents*))
1185    (when (or circle
1186              (not (and *circularity-hash-table*
1187                        (eq (setq circle (circularity-process xp object interior-cdr)) :subsequent))))
1188      (when *circularity-hash-table*
1189        (setq *xp-current-object* object))     
1190      (let ((printer (if pretty (get-printer object *print-pprint-dispatch*) nil))
1191            #|type|#)
1192        (cond (printer
1193               (funcall printer xp object))
1194              ((and pretty (maybe-print-fast xp object)))
1195              (t (write-not-pretty xp object
1196                                   (if *print-level*
1197                                     (- *print-level* *current-level*)
1198                                     most-positive-fixnum)
1199                                   interior-cdr circle)))))))
1200
1201;It is vital that this function be called EXACTLY once for each occurrence of
1202;  each thing in something being printed.
1203;Returns nil if printing should just continue on.
1204;  Either it is not a duplicate, or we are in the first pass and do not know.
1205;returns :FIRST if object is first occurrence of a DUPLICATE.
1206;  (This can only be returned on a second pass.)
1207;  After an initial code (printed by this routine on the second pass)
1208;  printing should continue on for the object.
1209;returns :SUBSEQUENT if second or later occurrence.
1210;  Printing is all taken care of by this routine.
1211
1212;Note many (maybe most) lisp implementations have characters and small numbers
1213;represented in a single word so that the are always eq when they are equal and the
1214;reader takes care of properly sharing them (just as it does with symbols).
1215;Therefore, we do not want circularity processing applied to them.  However,
1216;some kinds of numbers (e.g., bignums) undoubtedly are complex structures that
1217;the reader does not share.  However, they cannot have circular pointers in them
1218;and it is therefore probably a waste to do circularity checking on them.  In
1219;any case, it is not clear that it easy to tell exactly what kinds of numbers a
1220;given implementation of CL is going to have the reader automatically share.
1221
1222; if not pretty print a space before dot
1223
1224(defun circularity-process (xp object interior-cdr? &aux (not-pretty (not *print-pretty*)))
1225  (unless (or (numberp object)
1226              (characterp object)
1227              (and (symbolp object)     ;Reader takes care of sharing.
1228                   (or (null *print-gensym*) (symbol-package object))))
1229    (let ((id (gethash object *circularity-hash-table*)))
1230      (if (and *locating-circularities* *print-circle*) ; << was *locating-circularities*
1231        (progn ;(push (list object id info-p) barf)
1232          (cond ((null id)      ;never seen before
1233                 ;(when *parents* (push object *parents*))
1234                 (setf (gethash object *circularity-hash-table*) 0)
1235                 nil)
1236                ((zerop id) ;possible second occurrence
1237                 (setf (gethash object *circularity-hash-table*)
1238                       (incf *locating-circularities*))
1239                 :subsequent)
1240                (T :subsequent)));third or later occurrence
1241        (progn ;(push (list object id info-p interior-cdr?) barf2)         
1242          (cond 
1243           ((or (null id)       ;never seen before (note ~@* etc. conses)
1244                (zerop id));no duplicates
1245            nil)
1246           (t (when interior-cdr?
1247                (write-string++ (if not-pretty " . #" ". #")
1248                                            xp 0
1249                                            (if not-pretty 4 3)))
1250              (cond ((plusp id)
1251                     (cond (interior-cdr?
1252                            (decf *current-level*))
1253                           (T (write-char++ #\# xp)))
1254                     (print-fixnum xp id)
1255                     (write-char++ #\= xp)
1256                     (setf (gethash object *circularity-hash-table*) (- id))
1257                     :first)
1258                    (T (when (not interior-cdr?) (write-char++ #\# xp))
1259                       (print-fixnum xp (- id))
1260                       (write-char++ #\# xp)
1261                       :subsequent)))))))))
1262
1263;This prints a few very common, simple atoms very fast.
1264;Pragmatically, this turns out to be an enormous savings over going to the
1265;standard printer all the time.  There would be diminishing returns from making
1266;this work with more things, but might be worth it.
1267; does this really win?
1268
1269(defun maybe-print-fast (xp object)
1270  (cond ((stringp object)
1271         (cond ((null *print-escape*) (write-string+ object xp 0 (length object)) T)
1272               ((every #'(lambda (c) (not (or (eq c #\") (eq c #\\))))
1273                       object)
1274                (write-char++ #\" xp)
1275                (write-string+ object xp 0 (length object))
1276                (write-char++ #\" xp) T)))
1277        ((typep object 'fixnum)
1278         (when (and (null *print-radix*) (= *print-base* 10.))
1279           (when (minusp object)
1280             (write-char++ #\- xp)
1281             (setq object (- object)))
1282           (print-fixnum xp object) T))
1283        ((symbolp object)
1284         (if (> *print-base* 10) ; may need to escape potential numbers
1285           (write-a-symbol object (xp-stream xp))
1286           (let ((s (symbol-name object))
1287                 (p (symbol-package object))
1288                 (is-key (keywordp object))
1289                 (mode (case *print-case*
1290                         (:downcase :down)
1291                         (:capitalize :cap1)
1292                         (T nil)))) ; note no-escapes-needed requires all caps
1293             (declare (string s))
1294             (cond ((and (or is-key (eq p *package*)
1295                             (and  ;*package* ;can be NIL on symbolics
1296                              (multiple-value-bind (symbol type) (find-symbol s)
1297                                (and type (eq object symbol)))))
1298                         (eq (readtable-case *readtable*) :upcase)
1299                         (neq *print-case* :studly)
1300                         (no-escapes-needed s))
1301                    (when (and is-key *print-escape*)
1302                      (write-char++ #\: xp))
1303                    (if mode (push-char-mode xp mode))
1304                    (write-string++ s xp 0 (length s))
1305                    (if mode (pop-char-mode xp)) T)))))))
1306         
1307(defun print-fixnum (xp fixnum)
1308  (multiple-value-bind (digits d)
1309      (truncate fixnum 10)
1310    (unless (zerop digits)
1311      (print-fixnum xp digits))
1312    (write-char++ (code-char (+ #.(char-code #\0) d)) xp)))
1313
1314;just wants to succeed fast in a lot of common cases.
1315;assumes no funny readtable junk for the characters shown.
1316
1317(defun no-escapes-needed (s)
1318  (declare (string s))
1319  (let ((n (length s)))
1320    (declare (fixnum n))
1321    (and (not (zerop n))
1322         (let ((c (schar s 0)))
1323           (or (and (alpha-char-p c) (upper-case-p c)) (%str-member c "*<>")))
1324         (do ((i 1 (1+ i))) ((= i n) T)
1325           (declare (fixnum i))
1326           (let ((c (schar s i)))
1327             (if (not (or (digit-char-p c)
1328                          (and (alpha-char-p c) (upper-case-p c))
1329                          (%str-member c "*+<>-")))
1330                 (return nil)))))))
1331
1332
1333(defun pprint (object &optional (stream *standard-output*))
1334  "Prettily output OBJECT preceded by a newline."
1335  (setq stream (decode-stream-arg stream))
1336  (terpri stream)
1337  (let ((*print-escape* T) (*print-pretty* T))
1338    (write-1 object stream))
1339  (values))
1340
1341
1342;Any format string that is converted to a function is always printed
1343;via an XP stream (See formatter).
1344
1345(defvar *format-string-cache* nil)
1346
1347(defun process-format-string (string-or-fn force-fn?)
1348  (declare (ignore force-fn?))
1349  string-or-fn)
1350
1351
1352;Each of these causes the stream to be pessimistic and insert
1353;newlines wherever it might have to, when forcing the partial output
1354;out.  This is so that things will be in a consistent state if
1355;output continues to the stream later.
1356
1357(defmethod stream-force-output ((xp xp-structure))
1358  (attempt-to-output xp t t))
1359
1360(defmethod stream-finish-output ((xp xp-structure))
1361  (attempt-to-output xp t t))
1362
1363
1364;           ---- FUNCTIONAL INTERFACE TO DYNAMIC FORMATTING ----
1365
1366;The internal functions in this file, and the (formatter "...") expansions
1367;use the '+' forms of these functions directly (which is faster) because,
1368;they do not need error checking or fancy stream coercion.  The '++' forms
1369;additionally assume the thing being output does not contain a newline.
1370
1371
1372(defun pprint-newline (kind &optional (stream *standard-output*))
1373    "Output a conditional newline to STREAM (which defaults to
1374   *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do
1375   nothing if not. KIND can be one of:
1376     :LINEAR - A line break is inserted if and only if the immediatly
1377        containing section cannot be printed on one line.
1378     :MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
1379        (See *PRINT-MISER-WIDTH*.)
1380     :FILL - A line break is inserted if and only if either:
1381       (a) the following section cannot be printed on the end of the
1382           current line,
1383       (b) the preceding section was not printed on a single line, or
1384       (c) the immediately containing section cannot be printed on one
1385           line and miser-style is in effect.
1386     :MANDATORY - A line break is always inserted.
1387   When a line break is inserted by any type of conditional newline, any
1388   blanks that immediately precede the conditional newline are ommitted
1389   from the output and indentation is introduced at the beginning of the
1390   next line. (See PPRINT-INDENT.)"
1391    (when (not (memq kind '(:linear :miser :fill :mandatory)))
1392      (signal-type-error kind '(member :linear :miser :fill :mandatory) 
1393                         "Invalid KIND argument ~A to PPRINT-NEWLINE"))
1394    (when (and *print-pretty* *logical-block-p*)   
1395      (setq stream (decode-stream-arg stream))
1396      (cond ((xp-structure-p stream)
1397             (pprint-newline+ kind stream))
1398            ((typep stream 'xp-stream)
1399             (pprint-newline+ kind (slot-value stream 'xp-structure)))
1400            (t (pp-newline stream kind))))
1401    nil)
1402
1403(defun pprint-indent (relative-to n &optional (stream *standard-output*))
1404  "Specify the indentation to use in the current logical block if STREAM
1405   (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream
1406   and do nothing if not. (See PPRINT-LOGICAL-BLOCK.)  N is the indentation
1407   to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
1408     :BLOCK - Indent relative to the column the current logical block
1409        started on.
1410     :CURRENT - Indent relative to the current column.
1411   The new indentation value does not take effect until the following line
1412   break."
1413  (setq stream (decode-stream-arg stream))
1414  (when (not (memq relative-to '(:block :current)))
1415    (error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to))
1416  (cond ((xp-structure-p stream)
1417         (pprint-indent+ relative-to (truncate n) stream))
1418        ((typep stream 'xp-stream)
1419         (pprint-indent+ relative-to (truncate n) (slot-value stream 'xp-structure)))
1420        (t nil)) ; ???(break)))
1421  nil)
1422
1423(defun pprint-tab (kind colnum colinc &optional (stream *standard-output*))
1424  "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing
1425   stream, perform tabbing based on KIND, otherwise do nothing. KIND can
1426   be one of:
1427     :LINE - Tab to column COLNUM. If already past COLNUM tab to the next
1428       multiple of COLINC.
1429     :SECTION - Same as :LINE, but count from the start of the current
1430       section, not the start of the line.
1431     :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of
1432       COLINC.
1433     :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start
1434       of the current section, not the start of the line."
1435  (setq stream (decode-stream-arg stream))
1436  (when (not (memq kind '(:line :section :line-relative :section-relative)))
1437    (error "Invalid KIND argument ~A to PPRINT-TAB" kind))
1438
1439  (when (and *print-pretty* *logical-block-p*)
1440    (cond ((xp-structure-p stream)
1441           (pprint-tab+ kind colnum colinc stream))
1442          ((typep stream 'xp-stream)
1443           (pprint-tab+ kind colnum colinc (slot-value stream 'xp-structure)))))
1444  nil)
1445
1446;                        ---- COMPILED FORMAT ----
1447
1448;Note that compiled format strings always print through xp streams even if
1449;they don't have any xp directives in them.  As a result, the compiled code
1450;can depend on the fact that the stream being operated on is an xp
1451;stream not an ordinary one.
1452
1453
1454(eval-when (:compile-toplevel :load-toplevel :execute)
1455; called by formatter frobs
1456(defun do-sub-format-0 (s control-string args)
1457    (setq s (if (xp-structure-p s)(xp-stream s)
1458              (if (output-stream-p s)
1459                s
1460                (require-type s '(satisfies output-stream-p)))))
1461               
1462    (let ((*format-control-string* control-string)
1463          (*format-top-level* t))     
1464      (cond ((and (or *print-pretty* *print-circle*)
1465                  (not (typep s 'xp-stream)))
1466             (maybe-initiate-xp-printing
1467              #'do-sub-format-1 s args))
1468            (t (do-sub-format-1 s args)))))
1469
1470; called from above, format, and logical-block-sub
1471(defun do-sub-format-1 (stream args)
1472  (let ((*format-original-arguments* args)
1473        (*format-arguments* args)
1474        (*format-colon-rest* 'error))
1475    (declare (special *format-colon-rest*))
1476    (if (xp-structure-p stream)(setq stream (xp-stream stream)))
1477    (do-sub-format stream)
1478    ; copylist cause args is dynamic extent in format & formatter
1479    ; n.b. when printing lisp code its nearly always nil
1480    (setq args *format-arguments*)
1481    (if (and (consp args) *format-top-level*)(copy-list args) args)))
1482
1483(defmacro formatter (control-string) ; maybe-initiate-xp-printing?
1484  (setq control-string (require-type control-string 'string))
1485  `(function 
1486    (lambda (s &rest args)
1487      ; IFFY because things can end up in the same place on the stack
1488      ; appearing EQ giving bogus circularity detection
1489      ; But now we have fixed things so we don't circle check rest args (ha!)
1490      (do-sub-format-0 s ,control-string args))))
1491
1492(defmacro pprint-pop+ (args xp)
1493  `(if (pprint-pop-check+ ,args ,xp)
1494       (return-from logical-block nil)
1495       (pop ,args)))
1496
1497(defun pprint-pop-check+ (args xp)
1498  (let ((current-length *current-length*))
1499    (declare (fixnum current-length))
1500    (setq current-length (setq *current-length* (1+ *current-length*)))
1501    (cond ((not (listp args))  ;must be first so supersedes length abbrev
1502           (write-string++ ". " xp 0 2)
1503           (write+ args xp)
1504           T)
1505          ((and *print-length* ;must supersede circle check
1506                (not (< current-length *print-length*)))
1507           (write-string++ "..." xp 0 3)
1508           ;(setq *abbreviation-happened* T)
1509           T)
1510          ((and *circularity-hash-table* (not *format-top-level*)
1511                (not (zerop current-length)))
1512           (let ((circle (circularity-process xp args T)))
1513             (case circle
1514               (:first ;; note must inhibit rechecking of circularity for args.
1515                (write+ args xp T circle)
1516                T)
1517               (:subsequent T)
1518               (T nil)))))))
1519
1520(defun check-block-abbreviation (xp args circle-check?)
1521  (cond ((not (listp args)) (write+ args xp) T)
1522        ((and *print-level* (> *current-level* *print-level*))
1523         (write-char++ #\# XP) 
1524         ;(setq *abbreviation-happened* T)
1525         T)
1526        ((and *circularity-hash-table* circle-check? (neq args *xp-current-object*)
1527              (eq (circularity-process xp args nil) :subsequent))
1528         T)
1529        (T nil)))
1530
1531
1532)
1533
1534
1535;                ---- PRETTY PRINTING FORMATS ----
1536
1537(defun pretty-array (xp array)
1538  (when (typep xp 'xp-stream)(setq xp (slot-value xp 'xp-structure)))
1539  (cond ((vectorp array) (pretty-vector xp array))
1540        ((zerop (array-rank array))
1541         (write-string++ "#0A" xp 0 3)
1542         (write+ (aref array) xp))
1543        (T (pretty-non-vector xp array))))
1544
1545(defun pretty-vector (xp v)
1546  (pprint-logical-block (xp nil :prefix "#(" :suffix ")")
1547    (let ((end (length v)) (i 0))
1548      (declare (fixnum end i))
1549      (when (plusp end)
1550        (loop (pprint-pop)   ;HUH
1551              (write+ (aref v i) xp)
1552              (if (= (incf i) end) (return nil))
1553              (write-char++ #\space xp)
1554              (pprint-newline+ :fill xp))))))
1555
1556(defun pretty-non-vector (xp array)
1557  (let* ((bottom (1- (array-rank array)))
1558         (indices (make-list (1+ bottom) :initial-element 0))
1559         (dims (array-dimensions array)))
1560    (funcall (formatter "#~DA") xp (1+ bottom))
1561    (labels ((pretty-slice (slice)
1562               (pprint-logical-block (xp nil :prefix "(" :suffix ")")
1563                 (let ((end (nth slice dims))
1564                       (spot (nthcdr slice indices))
1565                       (i 0))
1566                   (when (plusp end)
1567                     (loop (pprint-pop)
1568                           (setf (car spot) i)
1569                           (if (= slice bottom)
1570                               (write+ (apply #'aref array indices) xp)
1571                               (pretty-slice (1+ slice)))
1572                           (if (= (incf i) end) (return nil))
1573                           (write-char++ #\space xp)
1574                           (pprint-newline+ (if (= slice bottom) :fill :linear) xp)))))))
1575      (pretty-slice 0))))
1576
1577(defun pretty-structure (xp struc &aux (class (struct-def struc)) (slots (sd-slots class)))
1578  (when (typep xp 'xp-stream)(setq xp (slot-value xp 'xp-structure)))
1579  (let* ((class (ccl::struct-def struc)) ;;guaranteed non-NIL if this function is called
1580         (pf (structure-print-function class)))
1581    (cond 
1582     (pf
1583      (if (consp pf)
1584        (funcall (car pf) struc (xp-stream xp))
1585        (funcall pf struc (xp-stream xp) *current-level*)))
1586     (t 
1587      (pprint-logical-block (xp nil :prefix "#S(" :suffix ")")
1588        (pprint-pop)
1589        (write+ (sd-name class) xp)
1590        (start-block xp (if (cdr slots) " " "") nil "")
1591        (when slots
1592          (let ((pcase *print-case*))
1593            (loop 
1594              (let* ((slot (pop slots))(name (ssd-name slot)))
1595                (cond
1596                 ((symbolp name)
1597                  (pprint-pop)
1598                  (write-char++ #\: xp)
1599                  (write-pname (symbol-name name) pcase xp)
1600                  (write-char++ #\space xp)
1601                  (pprint-pop)
1602                  (write+ (uvref struc (ssd-offset slot)) xp)             
1603                  (when (null slots)(return nil))
1604                  (write-char++ #\space xp)
1605                  (pprint-newline+ :fill xp))
1606                 ((null slots)(return nil)))))))
1607        (end-block xp ""))))))
1608
1609
1610
1611;Must use pprint-logical-block (no +) in the following three, because they are
1612;exported functions.
1613
1614(defun pprint-linear (s list &optional (colon? T) atsign?)
1615  "Output LIST to STREAM putting :LINEAR conditional newlines between each
1616   element. If COLON? is NIL (defaults to T), then no parens are printed
1617   around the output. ATSIGN? is ignored (but allowed so that PPRINT-LINEAR
1618   can be used with the ~/.../ format directive."
1619  (declare (ignore atsign?))
1620  (pprint-logical-block (s list :prefix (if colon? "(" "")
1621                                :suffix (if colon? ")" ""))
1622    (pprint-exit-if-list-exhausted)
1623    (loop (write+ (pprint-pop) s)
1624          (pprint-exit-if-list-exhausted)
1625          (write-char++ #\space s)
1626          (pprint-newline+ :linear s))))
1627
1628(defun pprint-fill (s list &optional (colon? T) atsign?)
1629  "Output LIST to STREAM putting :FILL conditional newlines between each
1630   element. If COLON? is NIL (defaults to T), then no parens are printed
1631   around the output. ATSIGN? is ignored (but allowed so that PPRINT-FILL
1632   can be used with the ~/.../ format directive."
1633  (declare (ignore atsign?))
1634  (pprint-logical-block (s list :prefix (if colon? "(" "")
1635                                :suffix (if colon? ")" ""))
1636    (pprint-exit-if-list-exhausted)
1637    (loop (write+ (pprint-pop) s)
1638          (pprint-exit-if-list-exhausted)
1639          (write-char++ #\space s)
1640          (pprint-newline+ :fill s))))
1641
1642(defun pprint-tabular (s list &optional (colon? T) atsign? (tabsize nil))
1643  "Output LIST to STREAM tabbing to the next column that is an even multiple
1644   of TABSIZE (which defaults to 16) between each element. :FILL style
1645   conditional newlines are also output between each element. If COLON? is
1646   NIL (defaults to T), then no parens are printed around the output.
1647   ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with
1648   the ~/.../ format directive."
1649  (declare (ignore atsign?))
1650  (when (null tabsize) (setq tabsize 16))
1651  (pprint-logical-block (s list :prefix (if colon? "(" "")
1652                                :suffix (if colon? ")" ""))   
1653    (pprint-exit-if-list-exhausted)
1654    (loop (write+ (pprint-pop) s)
1655          (pprint-exit-if-list-exhausted)
1656          (write-char++ #\space s)
1657          (pprint-tab+ :section-relative 0 tabsize s)
1658          (pprint-newline+ :fill s))))
1659
1660; perhaps should use alternate-fn-call instead
1661(defun fn-call (xp list)
1662  (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list))
1663
1664;Although idiosyncratic, I have found this very useful to avoid large
1665;indentations when printing out code.
1666
1667(defun alternative-fn-call (xp list)
1668  (if (> (length (symbol-name (car list))) 12)
1669      (funcall (formatter "~:<~1I~@{~W~^ ~_~}~:>") xp list)
1670      (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list)))
1671
1672(defun bind-list (xp list &rest args)
1673  (declare (ignore args))
1674  (if (do ((i 50 (1- i))
1675           (ls list (cdr ls))) ((null ls) t)
1676        (when (or (not (consp ls)) (not (symbolp (car ls))) (minusp i))
1677          (return nil)))
1678      (pprint-fill xp list)
1679      (funcall (formatter "~:<~@{~:/pprint-fill/~^ ~_~}~:>") xp list)))
1680
1681(defun block-like (xp list &rest args)
1682    (declare (ignore args))
1683  (funcall (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>") xp list))
1684
1685(defun defun-like (xp list &rest args)
1686    (declare (ignore args))
1687  (funcall (formatter "~:<~1I~W~^ ~@_~W~^ ~@_~:/pprint-fill/~^~@{ ~_~W~^~}~:>")
1688            xp list))
1689
1690(defun print-fancy-fn-call (xp list template)
1691  (let ((i 0) (in-first-section T))
1692    (declare (fixnum i))
1693    (pprint-logical-block+ (xp list "(" ")" nil T nil)
1694      (write+ (pprint-pop) xp)
1695      (pprint-indent+ :current 1 xp)
1696      (loop
1697        (pprint-exit-if-list-exhausted)
1698        (write-char++ #\space xp)
1699        (when (eq i (car template))
1700          (pprint-indent+ :block (cadr template) xp)
1701          (setq template (cddr template))
1702          (setq in-first-section nil))
1703        (pprint-newline (cond ((and (zerop i) in-first-section) :miser)
1704                              (in-first-section :fill)
1705                              (T :linear))
1706                        xp)
1707        (write+ (pprint-pop) xp)
1708        (incf i)))))
1709
1710(defun defmethod-like (xp list &rest args)
1711  (declare (ignore args))
1712  (cond ((and (consp (cdr list))(consp (cddr list))(listp (caddr list)))
1713         (defun-like xp list))
1714        (t (defsetf-print xp list))))
1715
1716
1717(defun maybelab (xp item &rest args)
1718    (declare (ignore args) (special need-newline indentation))
1719  (when (typep xp 'xp-stream)(setq xp (slot-value xp 'xp-structure)))
1720  (when need-newline (pprint-newline+ :mandatory xp))
1721  (cond ((and item (symbolp item))
1722         (write+ item xp)
1723         (setq need-newline nil))
1724        (T (pprint-tab+ :section indentation 0 xp)
1725           (write+ item xp)
1726           (setq need-newline T))))
1727
1728(defun function-call-p (x)
1729  (and (consp x) (symbolp (car x)) (fboundp (car x))))
1730
1731
1732
1733;THE FOLLOWING STUFF SETS UP THE DEFAULT *PRINT-PPRINT-DISPATCH*
1734 
1735;This is an attempt to specify a correct format for every form in the CL book
1736;that does not just get printed out like an ordinary function call
1737;(i.e., most special forms and many macros).  This of course does not
1738;cover anything new you define.
1739
1740(defun let-print (xp obj)
1741  (funcall (formatter "~:<~1I~W~^ ~@_~/ccl::bind-list/~^~@{ ~_~W~^~}~:>") xp obj))
1742
1743(defun cond-print (xp obj)
1744  (funcall (formatter "~:<~W~^ ~:I~@_~@{~:/pprint-linear/~^ ~_~}~:>") xp obj))
1745
1746(defun dmm-print (xp list)
1747  (print-fancy-fn-call xp list '(3 1)))
1748
1749(defun defsetf-print (xp list)
1750  (print-fancy-fn-call xp list '(3 1)))
1751
1752(defun do-print (xp obj)
1753  (funcall 
1754 (formatter "~:<~W~^ ~:I~@_~/ccl::bind-list/~^ ~_~:/pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>")
1755           xp obj))
1756
1757
1758(defun flet-print (xp obj)
1759  (funcall (formatter "~:<~1I~W~^ ~@_~:<~@{~/ccl::block-like/~^ ~_~}~:>~^~@{ ~_~W~^~}~:>")
1760           xp obj))
1761
1762(defun function-print (xp list)
1763  (if (and *print-abbreviate-quote* (consp (cdr list)) (null (cddr list)))
1764      (format (xp-stream xp) "#'~W" (cadr list))
1765      (fn-call xp list)))
1766
1767(defun mvb-print (xp list)
1768  (print-fancy-fn-call xp list '(1 3 2 1)))
1769
1770(defun prog-print (xp list)
1771  (let ((need-newline T) (indentation (1+ (length (symbol-name (car list)))))) ; less?
1772    (declare (special need-newline indentation))
1773    (funcall (formatter "~:<~W~^ ~:/pprint-fill/~^ ~@{~/ccl::maybelab/~^ ~}~:>")
1774             xp list)))
1775
1776
1777(defun progn-print (xp list)
1778  (funcall (formatter "~:<~1I~@{~W~^ ~_~}~:>") xp list))
1779
1780(defun setq-print (xp obj)
1781  (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>") xp obj))
1782
1783(defun quote-print (xp list)
1784  (if (and (consp (cdr list)) (null (cddr list)))
1785      (format (xp-stream xp) "'~W" (cadr list))
1786      (pprint-fill xp list)))
1787
1788(defun tagbody-print (xp list)
1789  (let ((need-newline (and (consp (cdr list))
1790                           (symbolp (cadr list)) (cadr list)))
1791        (indentation (1+ (length (symbol-name (car list))))))
1792    (declare (special need-newline indentation))
1793    (funcall (formatter "~:<~W~^ ~@{~/ccl::maybelab/~^ ~}~:>") xp list)))
1794
1795(defun up-print (xp list)
1796  (print-fancy-fn-call xp list '(0 3 1 1)))
1797
1798;here is some simple stuff for printing LOOP
1799
1800;The challange here is that we have to effectively parse the clauses of the
1801;loop in order to know how to print things.  Also you want to do this in a
1802;purely incremental way so that all of the abbreviation things work, and
1803;you wont blow up on circular lists or the like.  (More aesthic output could
1804;be produced by really parsing the clauses into nested lists before printing them.)
1805
1806;The following program assumes the following simplified grammar of the loop
1807;clauses that explains how to print them.  Note that it does not bare much
1808;resemblence to the right parsing grammar, however, it produces half decent
1809;output.  The way to make the output better is to make the grammar more
1810;detailed. 
1811;
1812;loop == (LOOP {clause}*)      ;one clause on each line.
1813;clause == block | linear | cond | finally
1814;block == block-head {expr}*   ;as many exprs as possible on each line.
1815;linear == linear-head {expr}* ;one expr on each line.
1816;finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line.
1817;cond == cond-head [expr]
1818;          clause
1819;          {AND clause}*       ;one AND on each line.
1820;        [ELSE
1821;          clause
1822;          {AND clause}*]      ;one AND on each line.
1823;        [END]
1824;block-head == FOR | AS | WITH | AND
1825;              | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN
1826;              | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT
1827;              | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING
1828;linear-head == DO | DOING | INITIALLY
1829;var-head == FOR | AS | WITH
1830;cond-head == IF | WHEN | UNLESS
1831;expr == <anything that is not a head symbol>
1832
1833;Note all the string comparisons below are required to support some
1834;existing implementations of LOOP.
1835(defun token-type (token &aux string)
1836  (cond ((not (symbolp token)) :expr)
1837        ((string= (setq string (string token)) "FINALLY") :finally)
1838        ((member string '("IF" "WHEN" "UNLESS") :test #'string=) :cond-head)
1839        ((member string '("DO" "DOING" "INITIALLY") :test #'string=) :linear-head)
1840        ((member string '("FOR" "AS" "WITH" "AND" "END" "ELSE"
1841                          "REPEAT" "NAMED" "WHILE" "UNTIL" "ALWAYS" "NEVER"
1842                          "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND"
1843                          "APPENDING" "NCONC" "NCONCING" "COUNT" "COUNTING"
1844                          "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING"
1845                          "MINIMIZE" "MINIMIZING")
1846                 :test #'string=)
1847         :block-head)
1848        (T :expr)))
1849
1850; maybe put in a separate file (replace write-char by write-char+)
1851(defun pretty-loop (xp loop)
1852  (if (not (and (consp (cdr loop)) (symbolp (cadr loop)))) ; old-style loop
1853      (tagbody-print xp loop)
1854      (pprint-logical-block (xp loop :prefix "(" :suffix ")")
1855        (let (token type)
1856          (labels ((next-token ()
1857                     (pprint-exit-if-list-exhausted)
1858                     (setq token (pprint-pop))
1859                     (setq type (token-type token)))
1860                   (print-clause (xp)
1861                     (case type
1862                       (:linear-head (print-exprs xp nil :mandatory))
1863                       (:cond-head (print-cond xp))
1864                       (:finally (print-exprs xp T :mandatory))
1865                       (otherwise (print-exprs xp nil :fill))))
1866                   (print-exprs (xp skip-first-non-expr newline-type)
1867                     (pprint-logical-block (xp nil)
1868                       (write+ token xp)
1869                       (next-token)
1870                       (when (and skip-first-non-expr (not (eq type :expr)))
1871                         (write-char+ #\space xp)
1872                         (write+ token xp)
1873                         (next-token))
1874                       (when (eq type :expr)
1875                         (write-char+ #\space xp)
1876                         (pprint-indent :current 0 xp)
1877                         (loop (write+ token xp)
1878                               (next-token)
1879                               (when (not (eq type :expr)) (return nil))
1880                               (write-char+ #\space xp)
1881                               (pprint-newline newline-type xp)))))
1882                   (print-cond (xp)
1883                     (pprint-logical-block (xp nil)
1884                       (write+ token xp)
1885                       (next-token)
1886                       (when (eq type :expr)
1887                         (write-char+ #\space xp)
1888                         (write+ token xp)
1889                         (next-token))
1890                       (write-char+ #\space xp)
1891                       (pprint-indent :block 2 xp)
1892                       (pprint-newline :linear xp)
1893                       (print-clause xp)
1894                       (print-and-list xp)
1895                       (when (string= (string token) "ELSE")
1896                         (print-else-or-end xp)
1897                         (write-char+ #\space xp)
1898                         (pprint-newline :linear xp)
1899                         (print-clause xp)
1900                         (print-and-list xp))
1901                       (when (string= (string token) "END")
1902                         (print-else-or-end xp))))
1903                   (print-and-list (xp)
1904                     (loop (when (not (string= (string token) "AND")) (return nil))
1905                           (write-char+ #\space xp)
1906                           (pprint-newline :mandatory xp)
1907                           (write+ token xp)
1908                           (next-token)
1909                           (write-char+ #\space xp)
1910                           (print-clause xp)))
1911                   (print-else-or-end (xp)
1912                     (write-char+ #\space xp)
1913                     (pprint-indent :block 0 xp)
1914                     (pprint-newline :linear xp)
1915                     (write+ token xp)
1916                     (next-token)
1917                     (pprint-indent :block 2 xp)))
1918            (pprint-exit-if-list-exhausted)
1919            (write+ (pprint-pop) xp)
1920            (next-token)
1921            (write-char+ #\space xp)
1922            (pprint-indent :current 0 xp)
1923            (loop (print-clause xp)
1924                  (write-char+ #\space xp)
1925                  (pprint-newline :linear xp)
1926                  ; without this we can loop forever
1927                  (if (and *print-level*
1928                           (>= *current-level* *print-level*))
1929                    (return))))))))
1930
1931;Backquote is a big problem we MUST do all this reconsing of structure in
1932;order to get a list that will trigger the right formatting functions to
1933;operate on it.  On the other side of the coin, we must use a non-list structure
1934;for the little backquote printing markers to ensure that they will always
1935;print out the way we want no matter what the code printers say.
1936;  Note that since it is sometimes possible to write the same
1937;backquote form in several ways, this might not necessarily print out a
1938;form in exactly the way you wrote it.  For example '`(a .,b) and '`(a ,@b)
1939;both print out as `'(a .,b), because the backquote reader produces the
1940;same code in both cases.
1941
1942
1943(setq *IPD* (make-pprint-dispatch-table))
1944
1945(set-pprint-dispatch+ '(satisfies function-call-p) #'alternative-fn-call '(-5) *IPD*)
1946(set-pprint-dispatch+ 'cons #'pprint-fill '(-10) *IPD*)
1947
1948(set-pprint-dispatch+ '(cons (member defstruct)) #'block-like '(0) *IPD*)
1949(set-pprint-dispatch+ '(cons (member block)) #'block-like '(0) *IPD*) 
1950(set-pprint-dispatch+ '(cons (member case)) #'block-like '(0) *IPD*) 
1951(set-pprint-dispatch+ '(cons (member catch)) #'block-like '(0) *IPD*) 
1952(set-pprint-dispatch+ '(cons (member ccase)) #'block-like '(0) *IPD*) 
1953(set-pprint-dispatch+ '(cons (member compiler-let)) #'let-print '(0) *IPD*)
1954(set-pprint-dispatch+ '(cons (member cond)) #'cond-print '(0) *IPD*)
1955(set-pprint-dispatch+ '(cons (member ctypecase)) #'block-like '(0) *IPD*)
1956(set-pprint-dispatch+ '(cons (member defclass)) #'defun-like '(0) *IPD*)
1957(set-pprint-dispatch+ '(cons (member ctypecase)) #'block-like '(0) *IPD*) 
1958(set-pprint-dispatch+ '(cons (member defconstant)) #'defun-like '(0) *IPD*)
1959(set-pprint-dispatch+ '(cons (member define-setf-expander)) #'defun-like '(0) *IPD*) 
1960(set-pprint-dispatch+ '(cons (member defmacro)) #'defun-like '(0) *IPD*) 
1961(set-pprint-dispatch+ '(cons (member define-modify-macro)) #'dmm-print '(0) *IPD*)
1962(set-pprint-dispatch+ '(cons (member defparameter)) #'defun-like '(0) *IPD*) 
1963(set-pprint-dispatch+ '(cons (member defsetf)) #'defsetf-print '(0) *IPD*)
1964(set-pprint-dispatch+ '(cons (member define-setf-expander)) #'defun-like '(0) *IPD*) 
1965(set-pprint-dispatch+ '(cons (member cl:defstruct)) #'block-like '(0) *IPD*) 
1966(set-pprint-dispatch+ '(cons (member deftype)) #'defun-like '(0) *IPD*) 
1967(set-pprint-dispatch+ '(cons (member defun)) #'defun-like '(0) *IPD*) 
1968(set-pprint-dispatch+ '(cons (member defmethod)) #'defmethod-like '(0) *IPD*) 
1969(set-pprint-dispatch+ '(cons (member defvar)) #'defun-like '(0) *IPD*) 
1970(set-pprint-dispatch+ '(cons (member do)) #'do-print '(0) *IPD*)
1971(set-pprint-dispatch+ '(cons (member do*)) #'do-print '(0) *IPD*) 
1972(set-pprint-dispatch+ '(cons (member do-all-symbols)) #'block-like '(0) *IPD*) 
1973(set-pprint-dispatch+ '(cons (member do-external-symbols)) #'block-like '(0) *IPD*) 
1974(set-pprint-dispatch+ '(cons (member do-symbols)) #'block-like '(0) *IPD*) 
1975(set-pprint-dispatch+ '(cons (member dolist)) #'block-like '(0) *IPD*) 
1976(set-pprint-dispatch+ '(cons (member dotimes)) #'block-like '(0) *IPD*) 
1977(set-pprint-dispatch+ '(cons (member ecase)) #'block-like '(0) *IPD*) 
1978(set-pprint-dispatch+ '(cons (member etypecase)) #'block-like '(0) *IPD*) 
1979(set-pprint-dispatch+ '(cons (member eval-when)) #'block-like '(0) *IPD*) 
1980(set-pprint-dispatch+ '(cons (member flet)) #'flet-print '(0) *IPD*)
1981(set-pprint-dispatch+ '(cons (member function)) #'function-print '(0) *IPD*)
1982(set-pprint-dispatch+ '(cons (member generic-function)) #'fn-call '(0) *IPD*)
1983(set-pprint-dispatch+ '(cons (member labels)) #'flet-print '(0) *IPD*) 
1984(set-pprint-dispatch+ '(cons (member lambda)) #'block-like '(0) *IPD*) 
1985(set-pprint-dispatch+ '(cons (member let)) #'let-print '(0) *IPD*)
1986(set-pprint-dispatch+ '(cons (member let*)) #'let-print '(0) *IPD*)
1987(set-pprint-dispatch+ '(cons (member locally)) #'block-like '(0) *IPD*)
1988
1989(set-pprint-dispatch+ '(cons (member loop)) #'pretty-loop '(0) *IPD*)
1990(set-pprint-dispatch+ '(cons (member macrolet)) #'flet-print '(0) *IPD*) 
1991(set-pprint-dispatch+ '(cons (member multiple-value-bind)) #'mvb-print '(0) *IPD*)
1992(set-pprint-dispatch+ '(cons (member multiple-value-setq)) #'block-like '(0) *IPD*) 
1993(set-pprint-dispatch+ '(cons (member prog)) #'prog-print '(0) *IPD*)
1994(set-pprint-dispatch+ '(cons (member prog*)) #'prog-print '(0) *IPD*)
1995(set-pprint-dispatch+ '(cons (member progv)) #'defun-like '(0) *IPD*)
1996(set-pprint-dispatch+ '(cons (member psetf)) #'setq-print '(0) *IPD*)
1997(set-pprint-dispatch+ '(cons (member psetq)) #'setq-print '(0) *IPD*)
1998(set-pprint-dispatch+ '(cons (member quote)) #'quote-print '(0) *IPD*)
1999(set-pprint-dispatch+ '(cons (member return-from)) #'block-like '(0) *IPD*)
2000(set-pprint-dispatch+ '(cons (member setf)) #'setq-print '(0) *IPD*)
2001(set-pprint-dispatch+ '(cons (member setq)) #'setq-print '(0) *IPD*)
2002(set-pprint-dispatch+ '(cons (member tagbody)) #'tagbody-print '(0) *IPD*)
2003(set-pprint-dispatch+ '(cons (member throw)) #'block-like '(0) *IPD*) 
2004(set-pprint-dispatch+ '(cons (member typecase)) #'block-like '(0) *IPD*) 
2005(set-pprint-dispatch+ '(cons (member unless)) #'block-like '(0) *IPD*) 
2006(set-pprint-dispatch+ '(cons (member unwind-protect)) #'up-print '(0) *IPD*)
2007(set-pprint-dispatch+ '(cons (member when)) #'block-like '(0) *IPD*) 
2008(set-pprint-dispatch+ '(cons (member with-input-from-string)) #'block-like '(0) *IPD*) 
2009(set-pprint-dispatch+ '(cons (member with-open-file)) #'block-like '(0) *IPD*)
2010(set-pprint-dispatch+ '(cons (member with-open-stream)) #'block-like '(0) *IPD*) 
2011(set-pprint-dispatch+ '(cons (member with-output-to-string)) #'block-like '(0) *IPD*) 
2012
2013
2014;so only happens first time is loaded. - why doesn't this work right?
2015; cause we have *print-pprin... bound to NIL
2016(when  t ;(eq *print-pprint-dispatch* T)
2017  (setq *print-pprint-dispatch* (copy-pprint-dispatch nil)))
2018
2019(setq *error-print-circle* t)  ; now we can circle-print
2020
2021; 82 bytes shorter but uglier
2022(defun write-not-pretty (stream object level list-kludge circle)
2023  (declare (type fixnum level) (type (or null fixnum) list-kludge))
2024  (when (xp-structure-p stream)(setq stream (xp-stream stream))) 
2025  (cond ((eq circle :subsequent)
2026         (if  list-kludge (stream-write-char stream #\)))
2027         (return-from write-not-pretty nil))
2028        ((not list-kludge))
2029        ((null object)(return-from write-not-pretty nil))
2030        ((not (consp object))
2031         (stream-write-entire-string stream " . "))
2032        ((eq circle :first)
2033         (stream-write-char stream #\()       
2034         (write-a-frob object stream level list-kludge)
2035         (stream-write-char stream #\))
2036         (return-from write-not-pretty nil))                     
2037        (t (stream-write-char stream #\space)))
2038  (write-a-frob object stream level list-kludge))
2039
2040(eval-when (:load-toplevel :execute) 
2041  (setq *error-print-circle* t))
2042
2043;changes since last documentation.
2044;~/fn/ only refers to global function values, not lexical.
2045
2046;------------------------------------------------------------------------
2047
2048;Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge,
2049;Massachusetts.
2050
2051;Permission to use, copy, modify, and distribute this software and its
2052;documentation for any purpose and without fee is hereby granted,
2053;provided that this copyright and permission notice appear in all
2054;copies and supporting documentation, and that the name of M.I.T. not
2055;be used in advertising or publicity pertaining to distribution of the
2056;software without specific, written prior permission. M.I.T. makes no
2057;representations about the suitability of this software for any
2058;purpose.  It is provided "as is" without express or implied warranty.
2059
2060;    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
2061;    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
2062;    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
2063;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
2064;    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
2065;    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
2066;    SOFTWARE.
2067
2068;------------------------------------------------------------------------
2069
2070#|
2071        Change History (most recent last):
2072        2       12/29/94        akh     merge with d13
2073|# ;(do not edit past this line!!)
Note: See TracBrowser for help on using the repository browser.