source: trunk/source/lib/pprint.lisp

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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