source: trunk/source/lib/pprint.lisp @ 9917

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

Move more definitions into lispequ. To bootstrap, (load "ccl:library;lispequ.lisp") before recompiling

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