source: branches/qres/ccl/lib/pprint.lisp @ 14172

Last change on this file since 14172 was 14058, checked in by gz, 9 years ago

support for code coverage of acode (r13891, r13929, r13942, r13964, r13965, r13966, r14044)

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