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

Last change on this file since 9266 was 9064, checked in by piso, 16 years ago

COPY-PPRINT-DISPATCH: (sys::require-type table 'pprint-dispatch-table)

File size: 14.7 KB
Line 
1;;; pprint-dispatch.lisp
2;;;
3;;; Copyright (C) 2004-2005 Peter Graves
4;;; $Id: pprint-dispatch.lisp,v 1.3 2005-05-05 15:49:28 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(defvar *ipd* nil ;see initialization at end of file.
49  "initial print dispatch table.")
50
51(defstruct (pprint-dispatch-table (:conc-name nil) (:copier nil))
52  (conses-with-cars (make-hash-table :test #'eq) :type hash-table)
53  (structures (make-hash-table :test #'eq) :type hash-table)
54  (others nil :type list))
55
56;The list and the hash-tables contain entries of the
57;following form.  When stored in the hash tables, the test entry is
58;the number of entries in the OTHERS list that have a higher priority.
59
60(defstruct (entry (:conc-name nil))
61  (test nil)        ;predicate function or count of higher priority others.
62  (fn nil)          ;pprint function
63  (full-spec nil))  ;list of priority and type specifier
64
65(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
66  (unless table
67    (setf table *ipd*))
68  (sys::require-type table 'pprint-dispatch-table)
69  (let* ((new-conses-with-cars
70          (make-hash-table :test #'eq
71                           :size (max (hash-table-count (conses-with-cars table)) 32)))
72   (new-structures
73          (make-hash-table :test #'eq
74                           :size (max (hash-table-count (structures table)) 32))))
75    (maphash #'(lambda (key value)
76                (setf (gethash key new-conses-with-cars) (copy-entry value)))
77       (conses-with-cars table))
78    (maphash #'(lambda (key value)
79                (setf (gethash key new-structures) (copy-entry value)))
80       (structures table))
81    (make-pprint-dispatch-table
82     :conses-with-cars new-conses-with-cars
83     :structures new-structures
84     :others (copy-list (others table)))))
85
86(defun set-pprint-dispatch (type-specifier function
87                                           &optional (priority 0) (table *print-pprint-dispatch*))
88  (when (or (not (numberp priority)) (complexp priority))
89    (error "invalid PRIORITY argument ~A to SET-PPRINT-DISPATCH" priority))
90  (set-pprint-dispatch+ type-specifier function priority table))
91
92(defun set-pprint-dispatch+ (type-specifier function priority table)
93  (let* ((category (specifier-category type-specifier))
94   (pred
95          (if (not (eq category 'other)) nil
96              (let ((pred (specifier-fn type-specifier)))
97                (if (and (consp (caddr pred))
98                         (symbolp (caaddr pred))
99                         (equal (cdaddr pred) '(x)))
100                    (symbol-function (caaddr pred))
101                    ;;                      (compile nil pred)
102                    pred
103                    ))))
104   (entry (if function (make-entry :test pred
105           :fn function
106           :full-spec (list priority type-specifier)))))
107    (case category
108      (cons-with-car
109       (cond ((null entry) (remhash (cadadr type-specifier) (conses-with-cars table)))
110             (T (setf (test entry)
111                      (count-if #'(lambda (e)
112                                   (priority-> (car (full-spec e)) priority))
113                                (others table)))
114                (setf (gethash (cadadr type-specifier) (conses-with-cars table)) entry))))
115      (structure-type
116       (cond ((null entry) (remhash type-specifier (structures table)))
117             (T (setf (test entry)
118                      (count-if #'(lambda (e)
119                                   (priority-> (car (full-spec e)) priority))
120                                (others table)))
121                (setf (gethash type-specifier (structures table)) entry))))
122      (T ;other
123       (let ((old (car (member type-specifier (others table) :test #'equal
124                               :key #'(lambda (e) (cadr (full-spec e)))))))
125         (when old
126           (setf (others table) (delete old (others table)))
127           (adjust-counts table (car (full-spec old)) -1)))
128       (when entry
129         (let ((others (cons nil (others table))))
130           (do ((l others (cdr l)))
131               ((null (cdr l)) (rplacd l (list entry)))
132             (when (priority-> priority (car (full-spec (cadr l))))
133               (rplacd l (cons entry (cdr l)))
134               (return nil)))
135           (setf (others table) (cdr others)))
136         (adjust-counts table priority 1)))))
137  nil)
138
139(defun priority-> (x y)
140  (if (consp x)
141      (if (consp y) (> (car x) (car y)) nil)
142      (if (consp y) T (> x y))))
143
144
145(defun adjust-counts (table priority delta)
146  (maphash #'(lambda (key value)
147              (declare (ignore key))
148              (if (priority-> priority (car (full-spec value)))
149                  (incf (test value) delta)))
150     (conses-with-cars table))
151  (maphash #'(lambda (key value)
152              (declare (ignore key))
153              (if (priority-> priority (car (full-spec value)))
154                  (incf (test value) delta)))
155     (structures table)))
156
157(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
158  (unless table
159    (setf table *ipd*))
160  (let ((fn (get-printer object table)))
161    (values (or fn #'non-pretty-print) (not (null fn)))))
162
163(defun get-printer (object table)
164  (let* ((entry (if (consp object)
165        (gethash (car object) (conses-with-cars table))
166        (gethash (type-of object) (structures table)))))
167    (if (not entry)
168  (setq entry (find object (others table) :test #'fits))
169  (do ((i (test entry) (1- i))
170       (l (others table) (cdr l)))
171      ((zerop i))
172    (when (fits object (car l)) (setq entry (car l)) (return nil))))
173    (when entry (fn entry))))
174
175(defun fits (obj entry) (funcall (test entry) obj))
176
177(defun specifier-category (spec)
178  (cond ((and (consp spec)
179        (eq (car spec) 'cons)
180        (consp (cdr spec))
181        (null (cddr spec))
182        (consp (cadr spec))
183        (eq (caadr spec) 'member)
184        (consp (cdadr spec))
185        (null (cddadr spec)))
186   'cons-with-car)
187  ((and (symbolp spec)
188;;               (structure-type-p spec)
189              (get spec 'structure-printer)
190              )
191         'structure-type)
192  (T 'other)))
193
194(defvar *preds-for-specs*
195  '((T always-true) (cons consp) (simple-atom simple-atom-p) (other otherp)
196    (null null) (symbol symbolp) (atom atom) (cons consp)
197    (list listp) (number numberp) (integer integerp)
198    (rational rationalp) (float floatp) (complex complexp)
199    (character characterp) (string stringp) (bit-vector bit-vector-p)
200    (vector vectorp) (simple-vector simple-vector-p)
201    (simple-string simple-string-p) (simple-bit-vector simple-bit-vector-p)
202    (array arrayp) (package packagep) (function functionp)
203    (compiled-function compiled-function-p) (common commonp)))
204
205(defun always-true (x) (declare (ignore x)) T)
206
207(defun specifier-fn (spec)
208  `(lambda (x) ,(convert-body spec)))
209
210(defun convert-body (spec)
211  (cond ((atom spec)
212   (let ((pred (cadr (assoc spec *preds-for-specs*))))
213     (if pred `(,pred x) `(typep x ',spec))))
214  ((member (car spec) '(and or not))
215   (cons (car spec) (mapcar #'convert-body (cdr spec))))
216  ((eq (car spec) 'member)
217   `(member x ',(copy-list (cdr spec))))
218  ((eq (car spec) 'cons)
219   `(and (consp x)
220         ,@(if (cdr spec) `((let ((x (car x)))
221            ,(convert-body (cadr spec)))))
222         ,@(if (cddr spec) `((let ((x (cdr x)))
223             ,(convert-body (caddr spec)))))))
224  ((eq (car spec) 'satisfies)
225   `(funcall (function ,(cadr spec)) x))
226        ((eq (car spec) 'eql)
227         `(eql x ',(cadr spec)))
228  (t
229         `(typep x ',(copy-tree spec)))))
230
231
232
233(defun function-call-p (x)
234  (and (consp x) (symbolp (car x)) (fboundp (car x))))
235
236
237
238(setq *ipd* (make-pprint-dispatch-table))
239
240(set-pprint-dispatch+ '(satisfies function-call-p) 'fn-call '(-5) *ipd*)
241(set-pprint-dispatch+ 'cons 'pprint-fill '(-10) *ipd*)
242
243(set-pprint-dispatch+ '(cons (member block)) 'block-like '(0) *ipd*)
244(set-pprint-dispatch+ '(cons (member case)) 'block-like '(0) *ipd*)
245(set-pprint-dispatch+ '(cons (member catch)) 'block-like '(0) *ipd*)
246(set-pprint-dispatch+ '(cons (member ccase)) 'block-like '(0) *ipd*)
247(set-pprint-dispatch+ '(cons (member compiler-let)) 'let-print '(0) *ipd*)
248(set-pprint-dispatch+ '(cons (member cond)) 'cond-print '(0) *ipd*)
249(set-pprint-dispatch+ '(cons (member ctypecase)) 'block-like '(0) *ipd*)
250(set-pprint-dispatch+ '(cons (member defconstant)) 'defun-like '(0) *ipd*)
251(set-pprint-dispatch+ '(cons (member define-setf-method)) 'defun-like '(0) *ipd*)
252(set-pprint-dispatch+ '(cons (member defmacro)) 'defun-like '(0) *ipd*)
253(set-pprint-dispatch+ '(cons (member define-modify-macro)) 'dmm-print '(0) *ipd*)
254(set-pprint-dispatch+ '(cons (member defparameter)) 'defun-like '(0) *ipd*)
255(set-pprint-dispatch+ '(cons (member defsetf)) 'defsetf-print '(0) *ipd*)
256(set-pprint-dispatch+ '(cons (member define-setf-method)) 'defun-like '(0) *ipd*)
257(set-pprint-dispatch+ '(cons (member defstruct)) 'block-like '(0) *ipd*)
258(set-pprint-dispatch+ '(cons (member deftype)) 'defun-like '(0) *ipd*)
259(set-pprint-dispatch+ '(cons (member defun)) 'defun-like '(0) *ipd*)
260(set-pprint-dispatch+ '(cons (member defvar)) 'defun-like '(0) *ipd*)
261(set-pprint-dispatch+ '(cons (member do)) 'do-print '(0) *ipd*)
262(set-pprint-dispatch+ '(cons (member do*)) 'do-print '(0) *ipd*)
263(set-pprint-dispatch+ '(cons (member do-all-symbols)) 'block-like '(0) *ipd*)
264(set-pprint-dispatch+ '(cons (member do-external-symbols)) 'block-like '(0) *ipd*)
265(set-pprint-dispatch+ '(cons (member do-symbols)) 'block-like '(0) *ipd*)
266(set-pprint-dispatch+ '(cons (member dolist)) 'block-like '(0) *ipd*)
267(set-pprint-dispatch+ '(cons (member dotimes)) 'block-like '(0) *ipd*)
268(set-pprint-dispatch+ '(cons (member ecase)) 'block-like '(0) *ipd*)
269(set-pprint-dispatch+ '(cons (member etypecase)) 'block-like '(0) *ipd*)
270(set-pprint-dispatch+ '(cons (member eval-when)) 'block-like '(0) *ipd*)
271(set-pprint-dispatch+ '(cons (member flet)) 'flet-print '(0) *ipd*)
272(set-pprint-dispatch+ '(cons (member function)) 'function-print '(0) *ipd*)
273(set-pprint-dispatch+ '(cons (member labels)) 'flet-print '(0) *ipd*)
274(set-pprint-dispatch+ '(cons (member lambda)) 'block-like '(0) *ipd*)
275(set-pprint-dispatch+ '(cons (member let)) 'let-print '(0) *ipd*)
276(set-pprint-dispatch+ '(cons (member let*)) 'let-print '(0) *ipd*)
277(set-pprint-dispatch+ '(cons (member locally)) 'block-like '(0) *ipd*)
278(set-pprint-dispatch+ '(cons (member loop)) 'pretty-loop '(0) *ipd*)
279(set-pprint-dispatch+ '(cons (member macrolet)) 'flet-print '(0) *ipd*)
280(set-pprint-dispatch+ '(cons (member multiple-value-bind)) 'mvb-print '(0) *ipd*)
281(set-pprint-dispatch+ '(cons (member multiple-value-setq)) 'block-like '(0) *ipd*)
282(set-pprint-dispatch+ '(cons (member prog)) 'prog-print '(0) *ipd*)
283(set-pprint-dispatch+ '(cons (member prog*)) 'prog-print '(0) *ipd*)
284(set-pprint-dispatch+ '(cons (member progv)) 'defun-like '(0) *ipd*)
285(set-pprint-dispatch+ '(cons (member psetf)) 'setq-print '(0) *ipd*)
286(set-pprint-dispatch+ '(cons (member psetq)) 'setq-print '(0) *ipd*)
287(set-pprint-dispatch+ '(cons (member quote)) 'quote-print '(0) *ipd*)
288(set-pprint-dispatch+ '(cons (member return-from)) 'block-like '(0) *ipd*)
289(set-pprint-dispatch+ '(cons (member setf)) 'setq-print '(0) *ipd*)
290(set-pprint-dispatch+ '(cons (member setq)) 'setq-print '(0) *ipd*)
291(set-pprint-dispatch+ '(cons (member tagbody)) 'tagbody-print '(0) *ipd*)
292(set-pprint-dispatch+ '(cons (member throw)) 'block-like '(0) *ipd*)
293(set-pprint-dispatch+ '(cons (member typecase)) 'block-like '(0) *ipd*)
294(set-pprint-dispatch+ '(cons (member unless)) 'block-like '(0) *ipd*)
295(set-pprint-dispatch+ '(cons (member unwind-protect)) 'up-print '(0) *ipd*)
296(set-pprint-dispatch+ '(cons (member when)) 'block-like '(0) *ipd*)
297(set-pprint-dispatch+ '(cons (member with-input-from-string)) 'block-like '(0) *ipd*)
298(set-pprint-dispatch+ '(cons (member with-open-file)) 'block-like '(0) *ipd*)
299(set-pprint-dispatch+ '(cons (member with-open-stream)) 'block-like '(0) *ipd*)
300(set-pprint-dispatch+ '(cons (member with-output-to-string)) 'block-like '(0) *ipd*)
301
302(defun pprint-dispatch-print (xp table)
303  (let ((stuff (copy-list (others table))))
304    (maphash #'(lambda (key val) (declare (ignore key))
305                (push val stuff))
306       (conses-with-cars table))
307    (maphash #'(lambda (key val) (declare (ignore key))
308                (push val stuff))
309       (structures table))
310    (setq stuff (sort stuff #'priority-> :key #'(lambda (x) (car (full-spec x)))))
311    (pprint-logical-block (xp stuff :prefix "#<" :suffix ">")
312                          (format xp (formatter "pprint dispatch table containing ~A entries: ")
313                                  (length stuff))
314                          (loop (pprint-exit-if-list-exhausted)
315                            (let ((entry (pprint-pop)))
316                              (format xp (formatter "~{~_P=~4D ~W~} F=~W ")
317                                      (full-spec entry) (fn entry)))))))
318
319(setf (get 'pprint-dispatch-table 'structure-printer) #'pprint-dispatch-print)
320
321(set-pprint-dispatch+ 'pprint-dispatch-table #'pprint-dispatch-print '(0) *ipd*)
322
323(setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
Note: See TracBrowser for help on using the repository browser.