| 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") |
|---|
