source: trunk/j/src/org/armedbear/lisp/pprint-dispatch.lisp @ 7856

Last change on this file since 7856 was 7856, checked in by piso, 17 years ago

Initial checkin.

File size: 14.6 KB
Line 
1;;; pprint-dispatch.lisp
2;;;
3;;; Copyright (C) 2004 Peter Graves
4;;; $Id: pprint-dispatch.lisp,v 1.1 2004-09-29 18:59:30 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20;;; Adapted from the November, 26 1991 version of Richard C. Waters' XP pretty
21;;; printer.
22
23;------------------------------------------------------------------------
24
25;Copyright Massachusetts Institute of Technology, Cambridge, Massachusetts.
26
27;Permission to use, copy, modify, and distribute this software and its
28;documentation for any purpose and without fee is hereby granted,
29;provided that this copyright and permission notice appear in all
30;copies and supporting documentation, and that the name of M.I.T. not
31;be used in advertising or publicity pertaining to distribution of the
32;software without specific, written prior permission. M.I.T. makes no
33;representations about the suitability of this software for any
34;purpose.  It is provided "as is" without express or implied warranty.
35
36;    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
37;    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
38;    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
39;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
40;    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
41;    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
42;    SOFTWARE.
43
44;------------------------------------------------------------------------
45
46(in-package #:xp)
47
48(defstruct (pprint-dispatch-table (:conc-name nil) (:copier nil))
49  (conses-with-cars (make-hash-table :test #'eq) :type hash-table)
50  (structures (make-hash-table :test #'eq) :type hash-table)
51  (others nil :type list))
52
53;The list and the hash-tables contain entries of the
54;following form.  When stored in the hash tables, the test entry is
55;the number of entries in the OTHERS list that have a higher priority.
56
57(defstruct (entry (:conc-name nil))
58  (test nil)        ;predicate function or count of higher priority others.
59  (fn nil)          ;pprint function
60  (full-spec nil))  ;list of priority and type specifier
61
62(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
63  (when (null table) (setf table *IPD*))
64  (let* ((new-conses-with-cars
65          (make-hash-table :test #'eq
66                           :size (max (hash-table-count (conses-with-cars table)) 32)))
67   (new-structures
68          (make-hash-table :test #'eq
69                           :size (max (hash-table-count (structures table)) 32))))
70    (maphash #'(lambda (key value)
71                (setf (gethash key new-conses-with-cars) (copy-entry value)))
72       (conses-with-cars table))
73    (maphash #'(lambda (key value)
74                (setf (gethash key new-structures) (copy-entry value)))
75       (structures table))
76    (make-pprint-dispatch-table
77     :conses-with-cars new-conses-with-cars
78     :structures new-structures
79     :others (copy-list (others table)))))
80
81(defun set-pprint-dispatch (type-specifier function
82                                           &optional (priority 0) (table *print-pprint-dispatch*))
83  (when (or (not (numberp priority)) (complexp priority))
84    (error "invalid PRIORITY argument ~A to SET-PPRINT-DISPATCH" priority))
85  (set-pprint-dispatch+ type-specifier function priority table))
86
87(defun set-pprint-dispatch+ (type-specifier function priority table)
88  (let* ((category (specifier-category type-specifier))
89   (pred
90          (if (not (eq category 'other)) nil
91              (let ((pred (specifier-fn type-specifier)))
92                (if (and (consp (caddr pred))
93                         (symbolp (caaddr pred))
94                         (equal (cdaddr pred) '(x)))
95                    (symbol-function (caaddr pred))
96                    ;;                      (compile nil pred)
97                    pred
98                    ))))
99   (entry (if function (make-entry :test pred
100           :fn function
101           :full-spec (list priority type-specifier)))))
102    (case category
103      (cons-with-car
104       (cond ((null entry) (remhash (cadadr type-specifier) (conses-with-cars table)))
105             (T (setf (test entry)
106                      (count-if #'(lambda (e)
107                                   (priority-> (car (full-spec e)) priority))
108                                (others table)))
109                (setf (gethash (cadadr type-specifier) (conses-with-cars table)) entry))))
110      (structure-type
111       (cond ((null entry) (remhash type-specifier (structures table)))
112             (T (setf (test entry)
113                      (count-if #'(lambda (e)
114                                   (priority-> (car (full-spec e)) priority))
115                                (others table)))
116                (setf (gethash type-specifier (structures table)) entry))))
117      (T ;other
118       (let ((old (car (member type-specifier (others table) :test #'equal
119                               :key #'(lambda (e) (cadr (full-spec e)))))))
120         (when old
121           (setf (others table) (delete old (others table)))
122           (adjust-counts table (car (full-spec old)) -1)))
123       (when entry
124         (let ((others (cons nil (others table))))
125           (do ((l others (cdr l)))
126               ((null (cdr l)) (rplacd l (list entry)))
127             (when (priority-> priority (car (full-spec (cadr l))))
128               (rplacd l (cons entry (cdr l)))
129               (return nil)))
130           (setf (others table) (cdr others)))
131         (adjust-counts table priority 1)))))
132  nil)
133
134(defun priority-> (x y)
135  (if (consp x)
136      (if (consp y) (> (car x) (car y)) nil)
137      (if (consp y) T (> x y))))
138
139
140(defun adjust-counts (table priority delta)
141  (maphash #'(lambda (key value)
142              (declare (ignore key))
143              (if (priority-> priority (car (full-spec value)))
144                  (incf (test value) delta)))
145     (conses-with-cars table))
146  (maphash #'(lambda (key value)
147              (declare (ignore key))
148              (if (priority-> priority (car (full-spec value)))
149                  (incf (test value) delta)))
150     (structures table)))
151
152(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
153  (unless table
154    (setf table *IPD*))
155  (let ((fn (get-printer object table)))
156    (values (or fn #'non-pretty-print) (not (null fn)))))
157
158(defun get-printer (object table)
159  (let* ((entry (if (consp object)
160        (gethash (car object) (conses-with-cars table))
161        (gethash (type-of object) (structures table)))))
162    (if (not entry)
163  (setq entry (find object (others table) :test #'fits))
164  (do ((i (test entry) (1- i))
165       (l (others table) (cdr l)))
166      ((zerop i))
167    (when (fits object (car l)) (setq entry (car l)) (return nil))))
168    (when entry (fn entry))))
169
170(defun fits (obj entry) (funcall (test entry) obj))
171
172(defun specifier-category (spec)
173  (cond ((and (consp spec)
174        (eq (car spec) 'cons)
175        (consp (cdr spec))
176        (null (cddr spec))
177        (consp (cadr spec))
178        (eq (caadr spec) 'member)
179        (consp (cdadr spec))
180        (null (cddadr spec)))
181   'cons-with-car)
182  ((and (symbolp spec)
183;;               (structure-type-p spec)
184              (get spec 'structure-printer)
185              )
186         'structure-type)
187  (T 'other)))
188
189(defvar *preds-for-specs*
190  '((T always-true) (cons consp) (simple-atom simple-atom-p) (other otherp)
191    (null null) (symbol symbolp) (atom atom) (cons consp)
192    (list listp) (number numberp) (integer integerp)
193    (rational rationalp) (float floatp) (complex complexp)
194    (character characterp) (string stringp) (bit-vector bit-vector-p)
195    (vector vectorp) (simple-vector simple-vector-p)
196    (simple-string simple-string-p) (simple-bit-vector simple-bit-vector-p)
197    (array arrayp) (package packagep) (function functionp)
198    (compiled-function compiled-function-p) (common commonp)))
199
200(defun always-true (x) (declare (ignore x)) T)
201
202(defun specifier-fn (spec)
203  `(lambda (x) ,(convert-body spec)))
204
205(defun convert-body (spec)
206  (cond ((atom spec)
207   (let ((pred (cadr (assoc spec *preds-for-specs*))))
208     (if pred `(,pred x) `(typep x ',spec))))
209  ((member (car spec) '(and or not))
210   (cons (car spec) (mapcar #'convert-body (cdr spec))))
211  ((eq (car spec) 'member)
212   `(member x ',(copy-list (cdr spec))))
213  ((eq (car spec) 'cons)
214   `(and (consp x)
215         ,@(if (cdr spec) `((let ((x (car x)))
216            ,(convert-body (cadr spec)))))
217         ,@(if (cddr spec) `((let ((x (cdr x)))
218             ,(convert-body (caddr spec)))))))
219  ((eq (car spec) 'satisfies)
220   `(funcall (function ,(cadr spec)) x))
221        ((eq (car spec) 'eql)
222         `(eql x ',(cadr spec)))
223  (t
224         `(typep x ',(copy-tree spec)))))
225
226
227
228(defun function-call-p (x)
229  (and (consp x) (symbolp (car x)) (fboundp (car x))))
230
231
232
233(setq *IPD* (make-pprint-dispatch-table))
234
235(set-pprint-dispatch+ '(satisfies function-call-p) 'fn-call '(-5) *IPD*)
236(set-pprint-dispatch+ 'cons 'pprint-fill '(-10) *IPD*)
237
238(set-pprint-dispatch+ '(cons (member block)) 'block-like '(0) *IPD*)
239(set-pprint-dispatch+ '(cons (member case)) 'block-like '(0) *IPD*)
240(set-pprint-dispatch+ '(cons (member catch)) 'block-like '(0) *IPD*)
241(set-pprint-dispatch+ '(cons (member ccase)) 'block-like '(0) *IPD*)
242(set-pprint-dispatch+ '(cons (member compiler-let)) 'let-print '(0) *IPD*)
243(set-pprint-dispatch+ '(cons (member cond)) 'cond-print '(0) *IPD*)
244(set-pprint-dispatch+ '(cons (member ctypecase)) 'block-like '(0) *IPD*)
245(set-pprint-dispatch+ '(cons (member defconstant)) 'defun-like '(0) *IPD*)
246(set-pprint-dispatch+ '(cons (member define-setf-method)) 'defun-like '(0) *IPD*)
247(set-pprint-dispatch+ '(cons (member defmacro)) 'defun-like '(0) *IPD*)
248(set-pprint-dispatch+ '(cons (member define-modify-macro)) 'dmm-print '(0) *IPD*)
249(set-pprint-dispatch+ '(cons (member defparameter)) 'defun-like '(0) *IPD*)
250(set-pprint-dispatch+ '(cons (member defsetf)) 'defsetf-print '(0) *IPD*)
251(set-pprint-dispatch+ '(cons (member define-setf-method)) 'defun-like '(0) *IPD*)
252(set-pprint-dispatch+ '(cons (member defstruct)) 'block-like '(0) *IPD*)
253(set-pprint-dispatch+ '(cons (member deftype)) 'defun-like '(0) *IPD*)
254(set-pprint-dispatch+ '(cons (member defun)) 'defun-like '(0) *IPD*)
255(set-pprint-dispatch+ '(cons (member defvar)) 'defun-like '(0) *IPD*)
256(set-pprint-dispatch+ '(cons (member do)) 'do-print '(0) *IPD*)
257(set-pprint-dispatch+ '(cons (member do*)) 'do-print '(0) *IPD*)
258(set-pprint-dispatch+ '(cons (member do-all-symbols)) 'block-like '(0) *IPD*)
259(set-pprint-dispatch+ '(cons (member do-external-symbols)) 'block-like '(0) *IPD*)
260(set-pprint-dispatch+ '(cons (member do-symbols)) 'block-like '(0) *IPD*)
261(set-pprint-dispatch+ '(cons (member dolist)) 'block-like '(0) *IPD*)
262(set-pprint-dispatch+ '(cons (member dotimes)) 'block-like '(0) *IPD*)
263(set-pprint-dispatch+ '(cons (member ecase)) 'block-like '(0) *IPD*)
264(set-pprint-dispatch+ '(cons (member etypecase)) 'block-like '(0) *IPD*)
265(set-pprint-dispatch+ '(cons (member eval-when)) 'block-like '(0) *IPD*)
266(set-pprint-dispatch+ '(cons (member flet)) 'flet-print '(0) *IPD*)
267(set-pprint-dispatch+ '(cons (member function)) 'function-print '(0) *IPD*)
268(set-pprint-dispatch+ '(cons (member labels)) 'flet-print '(0) *IPD*)
269(set-pprint-dispatch+ '(cons (member lambda)) 'block-like '(0) *IPD*)
270(set-pprint-dispatch+ '(cons (member let)) 'let-print '(0) *IPD*)
271(set-pprint-dispatch+ '(cons (member let*)) 'let-print '(0) *IPD*)
272(set-pprint-dispatch+ '(cons (member locally)) 'block-like '(0) *IPD*)
273(set-pprint-dispatch+ '(cons (member loop)) 'pretty-loop '(0) *IPD*)
274(set-pprint-dispatch+ '(cons (member macrolet)) 'flet-print '(0) *IPD*)
275(set-pprint-dispatch+ '(cons (member multiple-value-bind)) 'mvb-print '(0) *IPD*)
276(set-pprint-dispatch+ '(cons (member multiple-value-setq)) 'block-like '(0) *IPD*)
277(set-pprint-dispatch+ '(cons (member prog)) 'prog-print '(0) *IPD*)
278(set-pprint-dispatch+ '(cons (member prog*)) 'prog-print '(0) *IPD*)
279(set-pprint-dispatch+ '(cons (member progv)) 'defun-like '(0) *IPD*)
280(set-pprint-dispatch+ '(cons (member psetf)) 'setq-print '(0) *IPD*)
281(set-pprint-dispatch+ '(cons (member psetq)) 'setq-print '(0) *IPD*)
282(set-pprint-dispatch+ '(cons (member quote)) 'quote-print '(0) *IPD*)
283(set-pprint-dispatch+ '(cons (member return-from)) 'block-like '(0) *IPD*)
284(set-pprint-dispatch+ '(cons (member setf)) 'setq-print '(0) *IPD*)
285(set-pprint-dispatch+ '(cons (member setq)) 'setq-print '(0) *IPD*)
286(set-pprint-dispatch+ '(cons (member tagbody)) 'tagbody-print '(0) *IPD*)
287(set-pprint-dispatch+ '(cons (member throw)) 'block-like '(0) *IPD*)
288(set-pprint-dispatch+ '(cons (member typecase)) 'block-like '(0) *IPD*)
289(set-pprint-dispatch+ '(cons (member unless)) 'block-like '(0) *IPD*)
290(set-pprint-dispatch+ '(cons (member unwind-protect)) 'up-print '(0) *IPD*)
291(set-pprint-dispatch+ '(cons (member when)) 'block-like '(0) *IPD*)
292(set-pprint-dispatch+ '(cons (member with-input-from-string)) 'block-like '(0) *IPD*)
293(set-pprint-dispatch+ '(cons (member with-open-file)) 'block-like '(0) *IPD*)
294(set-pprint-dispatch+ '(cons (member with-open-stream)) 'block-like '(0) *IPD*)
295(set-pprint-dispatch+ '(cons (member with-output-to-string)) 'block-like '(0) *IPD*)
296
297(defun pprint-dispatch-print (xp table)
298  (let ((stuff (copy-list (others table))))
299    (maphash #'(lambda (key val) (declare (ignore key))
300                (push val stuff))
301       (conses-with-cars table))
302    (maphash #'(lambda (key val) (declare (ignore key))
303                (push val stuff))
304       (structures table))
305    (setq stuff (sort stuff #'priority-> :key #'(lambda (x) (car (full-spec x)))))
306    (pprint-logical-block (xp stuff :prefix "#<" :suffix ">")
307                          (format xp (formatter "pprint dispatch table containing ~A entries: ")
308                                  (length stuff))
309                          (loop (pprint-exit-if-list-exhausted)
310                            (let ((entry (pprint-pop)))
311                              (format xp (formatter "~{~_P=~4D ~W~} F=~W ")
312                                      (full-spec entry) (fn entry)))))))
313
314(setf (get 'pprint-dispatch-table 'structure-printer) #'pprint-dispatch-print)
315
316(set-pprint-dispatch+ 'pprint-dispatch-table #'pprint-dispatch-print '(0) *IPD*)
317
318(setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
Note: See TracBrowser for help on using the repository browser.