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

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

Work in progress.

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