Ignore:
Timestamp:
10/04/04 16:33:50 (17 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/pprint-dispatch.lisp

    r7856 r7911  
    22;;;
    33;;; Copyright (C) 2004 Peter Graves
    4 ;;; $Id: pprint-dispatch.lisp,v 1.1 2004-09-29 18:59:30 piso Exp $
     4;;; $Id: pprint-dispatch.lisp,v 1.2 2004-10-04 16:33:50 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    4646(in-package #:xp)
    4747
     48(defvar *ipd* nil ;see initialization at end of file.
     49  "initial print dispatch table.")
     50
    4851(defstruct (pprint-dispatch-table (:conc-name nil) (:copier nil))
    4952  (conses-with-cars (make-hash-table :test #'eq) :type hash-table)
     
    6164
    6265(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
    63   (when (null table) (setf table *IPD*))
     66  (unless table
     67    (setf table *ipd*))
    6468  (let* ((new-conses-with-cars
    6569          (make-hash-table :test #'eq
     
    153157(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
    154158  (unless table
    155     (setf table *IPD*))
     159    (setf table *ipd*))
    156160  (let ((fn (get-printer object table)))
    157161    (values (or fn #'non-pretty-print) (not (null fn)))))
     
    233237
    234238
    235 (setq *IPD* (make-pprint-dispatch-table))
    236 
    237 (set-pprint-dispatch+ '(satisfies function-call-p) 'fn-call '(-5) *IPD*)
    238 (set-pprint-dispatch+ 'cons 'pprint-fill '(-10) *IPD*)
    239 
    240 (set-pprint-dispatch+ '(cons (member block)) 'block-like '(0) *IPD*)
    241 (set-pprint-dispatch+ '(cons (member case)) 'block-like '(0) *IPD*)
    242 (set-pprint-dispatch+ '(cons (member catch)) 'block-like '(0) *IPD*)
    243 (set-pprint-dispatch+ '(cons (member ccase)) 'block-like '(0) *IPD*)
    244 (set-pprint-dispatch+ '(cons (member compiler-let)) 'let-print '(0) *IPD*)
    245 (set-pprint-dispatch+ '(cons (member cond)) 'cond-print '(0) *IPD*)
    246 (set-pprint-dispatch+ '(cons (member ctypecase)) 'block-like '(0) *IPD*)
    247 (set-pprint-dispatch+ '(cons (member defconstant)) 'defun-like '(0) *IPD*)
    248 (set-pprint-dispatch+ '(cons (member define-setf-method)) 'defun-like '(0) *IPD*)
    249 (set-pprint-dispatch+ '(cons (member defmacro)) 'defun-like '(0) *IPD*)
    250 (set-pprint-dispatch+ '(cons (member define-modify-macro)) 'dmm-print '(0) *IPD*)
    251 (set-pprint-dispatch+ '(cons (member defparameter)) 'defun-like '(0) *IPD*)
    252 (set-pprint-dispatch+ '(cons (member defsetf)) 'defsetf-print '(0) *IPD*)
    253 (set-pprint-dispatch+ '(cons (member define-setf-method)) 'defun-like '(0) *IPD*)
    254 (set-pprint-dispatch+ '(cons (member defstruct)) 'block-like '(0) *IPD*)
    255 (set-pprint-dispatch+ '(cons (member deftype)) 'defun-like '(0) *IPD*)
    256 (set-pprint-dispatch+ '(cons (member defun)) 'defun-like '(0) *IPD*)
    257 (set-pprint-dispatch+ '(cons (member defvar)) 'defun-like '(0) *IPD*)
    258 (set-pprint-dispatch+ '(cons (member do)) 'do-print '(0) *IPD*)
    259 (set-pprint-dispatch+ '(cons (member do*)) 'do-print '(0) *IPD*)
    260 (set-pprint-dispatch+ '(cons (member do-all-symbols)) 'block-like '(0) *IPD*)
    261 (set-pprint-dispatch+ '(cons (member do-external-symbols)) 'block-like '(0) *IPD*)
    262 (set-pprint-dispatch+ '(cons (member do-symbols)) 'block-like '(0) *IPD*)
    263 (set-pprint-dispatch+ '(cons (member dolist)) 'block-like '(0) *IPD*)
    264 (set-pprint-dispatch+ '(cons (member dotimes)) 'block-like '(0) *IPD*)
    265 (set-pprint-dispatch+ '(cons (member ecase)) 'block-like '(0) *IPD*)
    266 (set-pprint-dispatch+ '(cons (member etypecase)) 'block-like '(0) *IPD*)
    267 (set-pprint-dispatch+ '(cons (member eval-when)) 'block-like '(0) *IPD*)
    268 (set-pprint-dispatch+ '(cons (member flet)) 'flet-print '(0) *IPD*)
    269 (set-pprint-dispatch+ '(cons (member function)) 'function-print '(0) *IPD*)
    270 (set-pprint-dispatch+ '(cons (member labels)) 'flet-print '(0) *IPD*)
    271 (set-pprint-dispatch+ '(cons (member lambda)) 'block-like '(0) *IPD*)
    272 (set-pprint-dispatch+ '(cons (member let)) 'let-print '(0) *IPD*)
    273 (set-pprint-dispatch+ '(cons (member let*)) 'let-print '(0) *IPD*)
    274 (set-pprint-dispatch+ '(cons (member locally)) 'block-like '(0) *IPD*)
    275 (set-pprint-dispatch+ '(cons (member loop)) 'pretty-loop '(0) *IPD*)
    276 (set-pprint-dispatch+ '(cons (member macrolet)) 'flet-print '(0) *IPD*)
    277 (set-pprint-dispatch+ '(cons (member multiple-value-bind)) 'mvb-print '(0) *IPD*)
    278 (set-pprint-dispatch+ '(cons (member multiple-value-setq)) 'block-like '(0) *IPD*)
    279 (set-pprint-dispatch+ '(cons (member prog)) 'prog-print '(0) *IPD*)
    280 (set-pprint-dispatch+ '(cons (member prog*)) 'prog-print '(0) *IPD*)
    281 (set-pprint-dispatch+ '(cons (member progv)) 'defun-like '(0) *IPD*)
    282 (set-pprint-dispatch+ '(cons (member psetf)) 'setq-print '(0) *IPD*)
    283 (set-pprint-dispatch+ '(cons (member psetq)) 'setq-print '(0) *IPD*)
    284 (set-pprint-dispatch+ '(cons (member quote)) 'quote-print '(0) *IPD*)
    285 (set-pprint-dispatch+ '(cons (member return-from)) 'block-like '(0) *IPD*)
    286 (set-pprint-dispatch+ '(cons (member setf)) 'setq-print '(0) *IPD*)
    287 (set-pprint-dispatch+ '(cons (member setq)) 'setq-print '(0) *IPD*)
    288 (set-pprint-dispatch+ '(cons (member tagbody)) 'tagbody-print '(0) *IPD*)
    289 (set-pprint-dispatch+ '(cons (member throw)) 'block-like '(0) *IPD*)
    290 (set-pprint-dispatch+ '(cons (member typecase)) 'block-like '(0) *IPD*)
    291 (set-pprint-dispatch+ '(cons (member unless)) 'block-like '(0) *IPD*)
    292 (set-pprint-dispatch+ '(cons (member unwind-protect)) 'up-print '(0) *IPD*)
    293 (set-pprint-dispatch+ '(cons (member when)) 'block-like '(0) *IPD*)
    294 (set-pprint-dispatch+ '(cons (member with-input-from-string)) 'block-like '(0) *IPD*)
    295 (set-pprint-dispatch+ '(cons (member with-open-file)) 'block-like '(0) *IPD*)
    296 (set-pprint-dispatch+ '(cons (member with-open-stream)) 'block-like '(0) *IPD*)
    297 (set-pprint-dispatch+ '(cons (member with-output-to-string)) 'block-like '(0) *IPD*)
     239(setq *ipd* (make-pprint-dispatch-table))
     240
     241(set-pprint-dispatch+ '(satisfies function-call-p) 'fn-call '(-5) *ipd*)
     242(set-pprint-dispatch+ 'cons 'pprint-fill '(-10) *ipd*)
     243
     244(set-pprint-dispatch+ '(cons (member block)) 'block-like '(0) *ipd*)
     245(set-pprint-dispatch+ '(cons (member case)) 'block-like '(0) *ipd*)
     246(set-pprint-dispatch+ '(cons (member catch)) 'block-like '(0) *ipd*)
     247(set-pprint-dispatch+ '(cons (member ccase)) 'block-like '(0) *ipd*)
     248(set-pprint-dispatch+ '(cons (member compiler-let)) 'let-print '(0) *ipd*)
     249(set-pprint-dispatch+ '(cons (member cond)) 'cond-print '(0) *ipd*)
     250(set-pprint-dispatch+ '(cons (member ctypecase)) 'block-like '(0) *ipd*)
     251(set-pprint-dispatch+ '(cons (member defconstant)) 'defun-like '(0) *ipd*)
     252(set-pprint-dispatch+ '(cons (member define-setf-method)) 'defun-like '(0) *ipd*)
     253(set-pprint-dispatch+ '(cons (member defmacro)) 'defun-like '(0) *ipd*)
     254(set-pprint-dispatch+ '(cons (member define-modify-macro)) 'dmm-print '(0) *ipd*)
     255(set-pprint-dispatch+ '(cons (member defparameter)) 'defun-like '(0) *ipd*)
     256(set-pprint-dispatch+ '(cons (member defsetf)) 'defsetf-print '(0) *ipd*)
     257(set-pprint-dispatch+ '(cons (member define-setf-method)) 'defun-like '(0) *ipd*)
     258(set-pprint-dispatch+ '(cons (member defstruct)) 'block-like '(0) *ipd*)
     259(set-pprint-dispatch+ '(cons (member deftype)) 'defun-like '(0) *ipd*)
     260(set-pprint-dispatch+ '(cons (member defun)) 'defun-like '(0) *ipd*)
     261(set-pprint-dispatch+ '(cons (member defvar)) 'defun-like '(0) *ipd*)
     262(set-pprint-dispatch+ '(cons (member do)) 'do-print '(0) *ipd*)
     263(set-pprint-dispatch+ '(cons (member do*)) 'do-print '(0) *ipd*)
     264(set-pprint-dispatch+ '(cons (member do-all-symbols)) 'block-like '(0) *ipd*)
     265(set-pprint-dispatch+ '(cons (member do-external-symbols)) 'block-like '(0) *ipd*)
     266(set-pprint-dispatch+ '(cons (member do-symbols)) 'block-like '(0) *ipd*)
     267(set-pprint-dispatch+ '(cons (member dolist)) 'block-like '(0) *ipd*)
     268(set-pprint-dispatch+ '(cons (member dotimes)) 'block-like '(0) *ipd*)
     269(set-pprint-dispatch+ '(cons (member ecase)) 'block-like '(0) *ipd*)
     270(set-pprint-dispatch+ '(cons (member etypecase)) 'block-like '(0) *ipd*)
     271(set-pprint-dispatch+ '(cons (member eval-when)) 'block-like '(0) *ipd*)
     272(set-pprint-dispatch+ '(cons (member flet)) 'flet-print '(0) *ipd*)
     273(set-pprint-dispatch+ '(cons (member function)) 'function-print '(0) *ipd*)
     274(set-pprint-dispatch+ '(cons (member labels)) 'flet-print '(0) *ipd*)
     275(set-pprint-dispatch+ '(cons (member lambda)) 'block-like '(0) *ipd*)
     276(set-pprint-dispatch+ '(cons (member let)) 'let-print '(0) *ipd*)
     277(set-pprint-dispatch+ '(cons (member let*)) 'let-print '(0) *ipd*)
     278(set-pprint-dispatch+ '(cons (member locally)) 'block-like '(0) *ipd*)
     279(set-pprint-dispatch+ '(cons (member loop)) 'pretty-loop '(0) *ipd*)
     280(set-pprint-dispatch+ '(cons (member macrolet)) 'flet-print '(0) *ipd*)
     281(set-pprint-dispatch+ '(cons (member multiple-value-bind)) 'mvb-print '(0) *ipd*)
     282(set-pprint-dispatch+ '(cons (member multiple-value-setq)) 'block-like '(0) *ipd*)
     283(set-pprint-dispatch+ '(cons (member prog)) 'prog-print '(0) *ipd*)
     284(set-pprint-dispatch+ '(cons (member prog*)) 'prog-print '(0) *ipd*)
     285(set-pprint-dispatch+ '(cons (member progv)) 'defun-like '(0) *ipd*)
     286(set-pprint-dispatch+ '(cons (member psetf)) 'setq-print '(0) *ipd*)
     287(set-pprint-dispatch+ '(cons (member psetq)) 'setq-print '(0) *ipd*)
     288(set-pprint-dispatch+ '(cons (member quote)) 'quote-print '(0) *ipd*)
     289(set-pprint-dispatch+ '(cons (member return-from)) 'block-like '(0) *ipd*)
     290(set-pprint-dispatch+ '(cons (member setf)) 'setq-print '(0) *ipd*)
     291(set-pprint-dispatch+ '(cons (member setq)) 'setq-print '(0) *ipd*)
     292(set-pprint-dispatch+ '(cons (member tagbody)) 'tagbody-print '(0) *ipd*)
     293(set-pprint-dispatch+ '(cons (member throw)) 'block-like '(0) *ipd*)
     294(set-pprint-dispatch+ '(cons (member typecase)) 'block-like '(0) *ipd*)
     295(set-pprint-dispatch+ '(cons (member unless)) 'block-like '(0) *ipd*)
     296(set-pprint-dispatch+ '(cons (member unwind-protect)) 'up-print '(0) *ipd*)
     297(set-pprint-dispatch+ '(cons (member when)) 'block-like '(0) *ipd*)
     298(set-pprint-dispatch+ '(cons (member with-input-from-string)) 'block-like '(0) *ipd*)
     299(set-pprint-dispatch+ '(cons (member with-open-file)) 'block-like '(0) *ipd*)
     300(set-pprint-dispatch+ '(cons (member with-open-stream)) 'block-like '(0) *ipd*)
     301(set-pprint-dispatch+ '(cons (member with-output-to-string)) 'block-like '(0) *ipd*)
    298302
    299303(defun pprint-dispatch-print (xp table)
     
    316320(setf (get 'pprint-dispatch-table 'structure-printer) #'pprint-dispatch-print)
    317321
    318 (set-pprint-dispatch+ 'pprint-dispatch-table #'pprint-dispatch-print '(0) *IPD*)
     322(set-pprint-dispatch+ 'pprint-dispatch-table #'pprint-dispatch-print '(0) *ipd*)
    319323
    320324(setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
Note: See TracChangeset for help on using the changeset viewer.