File: pprint.l

package info (click to toggle)
euslisp 9.31%2Bdfsg-3
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 55,448 kB
  • sloc: ansic: 41,610; lisp: 3,339; makefile: 286; sh: 238; asm: 138; python: 53
file content (164 lines) | stat: -rw-r--r-- 5,156 bytes parent folder | download | duplicates (2)
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$")