source: trunk/abcl/src/org/armedbear/lisp/pprint-dispatch.lisp

Last change on this file was 14112, checked in by ehuelsmann, 9 years ago

Use PROVIDE/REQUIRE to prevent multiple loading.

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