1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164
|
;;;
;;; pretty printer
;;;
(in-package "LISP")
(export '(spaces pf px pp-method pprint tprint pprint-file *undefined*))
(defun spaces (n &optional (file t)) (dotimes (i n) (princ " " file)))
(eval-when (load eval)
(defun px (x &optional (strm t)) (format strm "~X" x))
(defmacro pf (func &optional (file *standard-output*))
`(if (fboundp ',func)
(pprint (symbol-function ',func) ,file)
'*undefined*))
(defun pp-method (cls selector &optional (file *standard-output*))
; (declare (type metaclass cls))
(pprint (assoc selector (cls . methods)) file))
(defun pprint (sexp &optional (file *standard-output*) (tab 0) (platen 75))
(pprint1 sexp file tab platen)
(terpri file))
(defun pprint-file (obj file)
(with-open-file (s file :direction :output)
(pprint obj s)))
(defun pprint1 (sexp file pltn platen)
(cond
((or (symbolp sexp) (numberp sexp) (stringp sexp)
(< (print-size sexp (- platen pltn)) (- platen pltn)))
(prin1 sexp file))
((and (listp sexp) (eq (car sexp) 'quote))
(princ "'" file)
(setq sexp (cadr sexp))
(pprint1 sexp file pltn platen))
((and (derivedp sexp array)
(= (array-rank sexp) 2)
(< (array-total-size sexp) 100))
(pprint-array sexp file pltn))
((vectorp sexp)
(cond ((float-vector-p sexp) (princ "#f(" file) (inc pltn 3))
(t (princ "#(" file) (inc pltn 2)))
(let ((i 0) (s (length sexp)))
(declare (type integer i s))
(while (< i s)
(pprint1 (aref sexp i) file pltn platen)
(terpri file)
(spaces pltn file)
(inc i))
(princ ")" file)))
((atom sexp) (prin1 sexp file))
(t (princ "(" file)
(pprint1 (car sexp)
file
(if (listp (car sexp)) (1+ pltn) pltn)
platen)
(case (car sexp)
((defun defclass defmacro)
(spaces 1 file)
(princ (cadr sexp) file)
(spaces 1 file)
(pparg
(caddr sexp)
(+ (setq pltn (+ pltn 3)) (print-size (cadr sexp)))
platen file)
(setq sexp (cddr sexp)))
((lambda macro)
(spaces 1 file)
(pparg
(cadr sexp)
(+ (setq pltn (+ pltn 3)) (print-size (car sexp)))
platen file)
(setq sexp (cdr sexp)))
((set setq)
(while
(and (setq sexp (cdr sexp)) (cdr sexp))
(terpri file)
(spaces (+ pltn 3) file)
(princ (car sexp) file)
(spaces 1 file)
(pprint1 (cadr sexp)
file
(+ pltn (print-size (car sexp)) 4)
platen)
(setq sexp (cdr sexp)))
(setq sexp '(nil)))
(t
(if (and (symbolp (car sexp)) (fboundp (car sexp)))
(setq pltn (+ pltn 3))
(incf pltn)) ))
(while (and (listp sexp) (setq sexp (cdr sexp)))
(terpri file)
(spaces pltn file)
(cond ((atom sexp)
(princ ". " file)
(pprint1 sexp file (+ 2 pltn) platen))
(t (pprint1 (car sexp) file pltn platen))))
(princ ")" file))))
(defun pparg (sexp pltn platen file)
(cond
((or (atom sexp)
(< (print-size SEXP (- platen PLTN)) (- platen pltn)))
(prin1 SEXP FILE))
(T (let ((PLTN. nil))
(PRINc "(" FILE)
(SETQ PLTN. PLTN)
(WHILE SEXP
(COND
((< (SETQ PLTN. (+ PLTN. (print-SIZE (CAR SEXP)) 1))
platen)
(prin1 (CAR SEXP) FILE)
(AND (SETQ SEXP (CDR SEXP)) (princ " " FILE)))
(T (TERPRI FILE)
(SPACES PLTN FILE)
(SETQ PLTN. PLTN)
(pprint1 (CAR SEXP) FILE pltn. platen)
(AND (SETQ SEXP (CDR SEXP)) (princ " " FILE))
)))
(PRINc ")" FILE)))))
)
(defun pprint-array (a strm tab)
(let ((flag (cdr (assoc (send a :element-type)
'((:float . "f") (:integer . "i")))))
(dim0 (array-dimension a 0))
(dim1 (array-dimension a 1)))
(unless flag (setq flag "a"))
(format strm "#2~A(" flag)
(dotimes (i dim0)
(format strm "(")
(dotimes (j dim1)
(format strm "~S" (aref a i j))
(cond ((< (1+ j) dim1) (format strm " "))
(t (format strm ")"))))
(when (< (1+ i) (array-dimension a 0))
(format strm "~%")
(spaces (+ tab 4) strm)))
(format strm ")"))))
(eval-when (load eval)
(defun tprint (obj tab &optional (indent 0) (platen 79) (cpos 0))
"table-print obj tab [indent platen current-pos]"
(let ((pos cpos) (one-obj nil) (leng 0) (rest (- platen indent))
(size 0))
(spaces (- indent cpos))
(while obj
(setq one-obj (car obj))
(setq size (print-size one-obj))
(setq obj (cdr obj))
(setq leng (* tab (1+ (/ size tab))))
(cond ((> leng rest)
(terpri) (spaces indent)
(setq pos indent rest (- platen pos))))
(princ one-obj)
(spaces (- leng size))
(setq rest (- rest leng) pos (+ pos leng)))))
)
(provide :pprint "@(#)$Id$")
|