Commit | Line | Data |
---|---|---|
5ffa1c4c C |
1 | (setq rcs-pp- |
2 | "$Header: /usr/lib/lisp/RCS/pp.l,v 1.2 83/08/15 22:27:54 jkf Exp $") | |
3 | ||
4 | ;; | |
5 | ;; pp.l -[Mon Aug 15 10:52:13 1983 by jkf]- | |
6 | ;; | |
7 | ;; pretty printer for franz lisp | |
8 | ;; | |
9 | ||
10 | (declare (macros t)) | |
11 | ||
12 | (declare (special poport pparm1 pparm2 lpar rpar form linel)) | |
13 | ; (declare (localf $patom1 $prd1 $prdf charcnt condclosefile)) | |
14 | ||
15 | ; ======================================= | |
16 | ; pretty printer top level routine pp | |
17 | ; | |
18 | ; | |
19 | ; calling form- (pp arg1 arg2 ... argn) | |
20 | ; the args may be names of functions, atoms with associated values | |
21 | ; or output descriptors. | |
22 | ; if argi is: | |
23 | ; an atom - it is assumed to be a function name, if there is no | |
24 | ; function property associated with it,then it is assumed | |
25 | ; to be an atom with a value | |
26 | ; (P port)- port is the output port where the results of the | |
27 | ; pretty printing will be sent. | |
28 | ; poport is the default if no (P port) is given. | |
29 | ; (F fname)- fname is a file name to write the results in | |
30 | ; (A atmname) - means, treat this as an atom with a value, dont | |
31 | ; check if it is the name of a function. | |
32 | ; (E exp)- evaluate exp without printing anything | |
33 | ; other - pretty-print the expression as is - no longer an error | |
34 | ; | |
35 | ; Also, rather than printing only a function defn or only a value, we will | |
36 | ; let prettyprops decide which props to print. Finally, prettyprops will | |
37 | ; follow the CMULisp format where each element is either a property | |
38 | ; or a dotted pair of the form (prop . fn) where in order to print the | |
39 | ; given property we call (fn id val prop). The special properties | |
40 | ; function and value are used to denote those "properties" which | |
41 | ; do not actually appear on the plist. | |
42 | ; | |
43 | ; [history of this code: originally came from Harvard Lisp, hacked to | |
44 | ; work under franz at ucb, hacked to work at cmu and finally rehacked | |
45 | ; to work without special cmu macros] | |
46 | ||
47 | (declare (special $outport$ $fileopen$ prettyprops)) | |
48 | ||
49 | (setq prettyprops '((comment . pp-comment) | |
50 | (function . pp-function) | |
51 | (value . pp-value))) | |
52 | ||
53 | ; printret is like print yet it returns the value printed, this is used | |
54 | ; by pp | |
55 | (def printret | |
56 | (macro ($l$) | |
57 | `(progn (print ,@(cdr $l$)) ,(cadr $l$)))) | |
58 | ||
59 | (def pp | |
60 | (nlambda ($xlist$) | |
61 | (prog ($gcprint $outport$ $cur$ $fileopen$ $prl$ $atm$) | |
62 | ||
63 | (setq $gcprint nil) ; don't print | |
64 | ; gc messages in pp. | |
65 | ||
66 | (setq $outport$ poport) ; default port | |
67 | ; check if more to do, if not close output file if it is | |
68 | ; open and leave | |
69 | ||
70 | ||
71 | toploop (cond ((null (setq $cur$ (car $xlist$))) | |
72 | (condclosefile) | |
73 | (terpr) | |
74 | (return t))) | |
75 | ||
76 | (cond ((dtpr $cur$) | |
77 | (cond ((equal 'P (car $cur$)) ; specifying a port | |
78 | (condclosefile) ; close file if open | |
79 | (setq $outport$ (eval (cadr $cur$)))) | |
80 | ||
81 | ((equal 'F (car $cur$)) ; specifying a file | |
82 | (condclosefile) ; close file if open | |
83 | (setq $outport$ (outfile (cadr $cur$)) | |
84 | $fileopen$ t)) | |
85 | ||
86 | ||
87 | ((equal 'E (car $cur$)) | |
88 | (eval (cadr $cur$))) | |
89 | ||
90 | (t (pp-form $cur$ $outport$))) ;-DNC inserted | |
91 | (go botloop))) | |
92 | ||
93 | ||
94 | (mapc (function | |
95 | (lambda (prop) | |
96 | (prog (printer) | |
97 | (cond ((dtpr prop) | |
98 | (setq printer (cdr prop)) | |
99 | (setq prop (car prop))) | |
100 | (t (setq printer 'pp-prop))) | |
101 | (cond ((eq 'value prop) | |
102 | (and (boundp $cur$) | |
103 | (apply printer | |
104 | (list $cur$ | |
105 | (eval $cur$) | |
106 | 'value)) | |
107 | (terpr $outport$))) | |
108 | ((eq 'function prop) | |
109 | (and (getd $cur$) | |
110 | (cond ((not (bcdp (getd $cur$))) | |
111 | (apply printer | |
112 | (list $cur$ | |
113 | (getd $cur$) | |
114 | 'function))) | |
115 | ; restore message about | |
116 | ; bcd since otherwise you | |
117 | ; just get nothing and | |
118 | ; people were complaining. | |
119 | ; - dhl. | |
120 | #-cmu | |
121 | (t | |
122 | (msg N | |
123 | "pp: function " | |
124 | (or $cur$) | |
125 | " is machine coded (bcd) ")) | |
126 | ) | |
127 | (terpri $outport$))) | |
128 | ((get $cur$ prop) | |
129 | (apply printer | |
130 | (list $cur$ | |
131 | (get $cur$ prop) | |
132 | prop)) | |
133 | (terpri $outport$)))))) | |
134 | prettyprops) | |
135 | ||
136 | ||
137 | botloop (setq $xlist$ (cdr $xlist$)) | |
138 | ||
139 | (go toploop)))) | |
140 | ||
141 | (setq pparm1 50 pparm2 100) | |
142 | ||
143 | ; -DNC These "prettyprinter parameters" are used to decide when we should | |
144 | ; quit printing down the right margin and move back to the left - | |
145 | ; Do it when the leftmargin > pparm1 and there are more than pparm2 | |
146 | ; more chars to print in the expression | |
147 | ||
148 | ; cmu prefers dv instead of setq | |
149 | ||
150 | #+cmu | |
151 | (def pp-value (lambda (i v p) | |
152 | (terpri $outport$) | |
153 | (pp-form (list 'dv i v) $outport$))) | |
154 | ||
155 | #-cmu | |
156 | (def pp-value (lambda (i v p) | |
157 | ;;(terpr $outport$) ;; pp-form does an initial terpr. | |
158 | ;; we don't need two. | |
159 | (pp-form `(setq ,i ',v) $outport$))) | |
160 | ||
161 | (def pp-function (lambda (i v p) | |
162 | #+cmu (terpri $outport$) | |
163 | ;; | |
164 | ;; add test for traced functions and don't | |
165 | ;; print the trace mess, just the original | |
166 | ;; function. - dhl. | |
167 | ;; | |
168 | ;; this test might belong in the main pp | |
169 | ;; loop but fits in easily here. - dhl | |
170 | ;; | |
171 | (cond ((and (dtpr v) | |
172 | (dtpr (cadr v)) | |
173 | (memq (caadr v) | |
174 | '(T-nargs T-arglist)) | |
175 | (cond ((bcdp (get i 'trace-orig-fcn)) | |
176 | #-cmu | |
177 | (msg N | |
178 | "pp: function " | |
179 | (or i) | |
180 | " is machine coded (bcd) ") | |
181 | t) | |
182 | (t (pp-form | |
183 | (list 'def i | |
184 | (get i 'trace-orig-fcn)) | |
185 | $outport$) | |
186 | t)))) | |
187 | ; this function need to return t, but | |
188 | ; pp-form returns nil sometimes. | |
189 | (t (pp-form (list 'def i v) $outport$) | |
190 | t)))) | |
191 | ||
192 | (def pp-prop (lambda (i v p) | |
193 | #+cmu (terpri $outport$) | |
194 | (pp-form (list 'defprop i v p) $outport$))) | |
195 | ||
196 | (def condclosefile | |
197 | (lambda nil | |
198 | (cond ($fileopen$ | |
199 | (terpr $outport$) | |
200 | (close $outport$) | |
201 | (setq $fileopen$ nil))))) | |
202 | \f | |
203 | ; | |
204 | ; these routines are meant to be used by pp but since | |
205 | ; some people insist on using them we will set $outport$ to nil | |
206 | ; as the default | |
207 | (setq $outport$ nil) | |
208 | ||
209 | ||
210 | ||
211 | (defun pp-form (value &optional ($outport$ poport oport-p) (lmar 0)) | |
212 | ($prdf value lmar 0)) | |
213 | ||
214 | ; this is for compatability with old code, will remove soon -- jkf | |
215 | (def $prpr (lambda (x) (pp-form x $outport$))) | |
216 | ||
217 | ||
218 | \f | |
219 | (declare (special rmar)) ; -DNC this used to be m - I've tried to | |
220 | ; to fix up the pretty printer a bit. It | |
221 | ; used to mess up regularly on (a b .c) types | |
222 | ; of lists. Also printmacros have been added. | |
223 | ||
224 | (def $prdf | |
225 | (lambda (l lmar rmar) | |
226 | (prog nil | |
227 | ; | |
228 | ; - DNC - Here we try to fix the tendency to print a | |
229 | ; thin column down the right margin by allowing it | |
230 | ; to move back to the left if necessary. | |
231 | ; | |
232 | (cond ((and (>& lmar pparm1) (>& (flatc l (1+ pparm2)) pparm2)) | |
233 | (terpri $outport$) | |
234 | (patom "; <<<<< start back on the left <<<<<" $outport$) | |
235 | ($prdf l 5 0) | |
236 | (terpri $outport$) | |
237 | (patom "; >>>>> continue on the right >>>>>" $outport$) | |
238 | (terpri $outport$) | |
239 | (return nil))) | |
240 | (tab lmar $outport$) | |
241 | a (cond ((and (dtpr l) | |
242 | (atom (car l)) | |
243 | (or (and (get (car l) 'printmacro) | |
244 | (funcall (get (car l) 'printmacro) | |
245 | l lmar rmar)) | |
246 | (and (get (car l) 'printmacrochar) | |
247 | (printmacrochar (get (car l) 'printmacrochar) | |
248 | l lmar rmar)))) | |
249 | (return nil)) | |
250 | ; | |
251 | ; -DNC - a printmacro is a lambda (l lmar rmar) | |
252 | ; attached to the atom. If it returns nil then | |
253 | ; we assume it did not apply and we continue. | |
254 | ; Otherwise we assume it did the job. | |
255 | ; | |
256 | ((or (not (dtpr l)) | |
257 | ; (*** at the moment we just punt hunks etc) | |
258 | (and (atom (car l)) (atom (cdr l)))) | |
259 | (return (printret l $outport$))) | |
260 | ((<& (+ rmar (flatc l (charcnt $outport$))) | |
261 | (charcnt $outport$)) | |
262 | ; | |
263 | ; This is just a heuristic - if print can fit it in then figure that | |
264 | ; the printmacros won't hurt. Note that despite the pretentions there | |
265 | ; is no guarantee that everything will fit in before rmar - for example | |
266 | ; atoms (and now even hunks) are just blindly printed. - DNC | |
267 | ; | |
268 | (printaccross l lmar rmar)) | |
269 | ((and ($patom1 lpar) | |
270 | (atom (car l)) | |
271 | (not (atom (cdr l))) | |
272 | (not (atom (cddr l)))) | |
273 | (prog (c) | |
274 | (printret (car l) $outport$) | |
275 | ($patom1 '" ") | |
276 | (setq c (nwritn $outport$)) | |
277 | a ($prd1 (cdr l) c) | |
278 | (cond | |
279 | ((not (atom (cdr (setq l (cdr l))))) | |
280 | (terpr $outport$) | |
281 | (go a))))) | |
282 | (t | |
283 | (prog (c) | |
284 | (setq c (nwritn $outport$)) | |
285 | a ($prd1 l c) | |
286 | (cond | |
287 | ((not (atom (setq l (cdr l)))) | |
288 | (terpr $outport$) | |
289 | (go a)))))) | |
290 | b ($patom1 rpar)))) | |
291 | ||
292 | (def $prd1 | |
293 | (lambda (l n) | |
294 | (prog nil | |
295 | ($prdf (car l) | |
296 | n | |
297 | (cond ((null (setq l (cdr l))) (|1+| rmar)) | |
298 | ((atom l) (setq n nil) (plus 4 rmar (pntlen l))) | |
299 | (t rmar))) | |
300 | (cond | |
301 | ((null n) ($patom1 '" . ") (return (printret l $outport$)))) | |
302 | ; (*** setting n is pretty disgusting) | |
303 | ; (*** the last arg to $prdf is the space needed for the suffix) | |
304 | ; ;Note that this is still not really right - if the prefix | |
305 | ; takes several lines one would like to use the old rmar | |
306 | ; until the last line where the " . mumble)" goes. | |
307 | ))) | |
308 | ||
309 | ; -DNC here's the printmacro for progs - it replaces some hackery that | |
310 | ; used to be in the guts of $prdf. | |
311 | ||
312 | (def printprog | |
313 | (lambda (l lmar rmar) | |
314 | (prog (col) | |
315 | (cond ((cdr (last l)) (return nil))) | |
316 | (setq col (add1 lmar)) | |
317 | (princ '|(| $outport$) | |
318 | (princ (car l) $outport$) | |
319 | (princ '| | $outport$) | |
320 | (print (cadr l) $outport$) | |
321 | (mapc '(lambda (x) | |
322 | (cond ((atom x) | |
323 | (tab col $outport$) | |
324 | (print x $outport$)) | |
325 | (t ($prdf x (+ lmar 6) rmar)))) | |
326 | (cddr l)) | |
327 | (princ '|)| $outport$) | |
328 | (return t)))) | |
329 | ||
330 | (putprop 'prog 'printprog 'printmacro) | |
331 | ||
332 | ;; | |
333 | ;; simpler version which | |
334 | ;; should look nice for lambda's also.(inside mapcar's) -dhl | |
335 | ;; | |
336 | (defun print-lambda (l lmar rmar) | |
337 | (prog (col) | |
338 | (cond ((cdr (last l)) (return nil))) | |
339 | (setq col (add1 lmar)) | |
340 | (princ '|(| $outport$) | |
341 | (princ (car l) $outport$) | |
342 | (princ '| | $outport$) | |
343 | (print (cadr l) $outport$) | |
344 | (let ((c (cond ((eq (car l) 'lambda) | |
345 | 8) | |
346 | (t 9)))) | |
347 | (mapc '(lambda (x) | |
348 | ($prdf x (+ lmar c) rmar)) | |
349 | (cddr l))) | |
350 | (princ '|)| $outport$) | |
351 | (terpr $outport$) | |
352 | (tab lmar $outport$) | |
353 | (return t))) | |
354 | ||
355 | (putprop 'lambda 'print-lambda 'printmacro) | |
356 | (putprop 'nlambda 'print-lambda 'printmacro) | |
357 | ||
358 | ; Here's the printmacro for def. The original $prdf had some special code | |
359 | ; for lambda and nlambda. | |
360 | ||
361 | (def printdef | |
362 | (lambda (l lmar rmar) | |
363 | (cond ((and (zerop lmar) ; only if we're really printing a defn | |
364 | (zerop rmar) | |
365 | (cadr l) | |
366 | (atom (cadr l)) | |
367 | (dtpr (caddr l)) | |
368 | (null (cdddr l)) | |
369 | (memq (caaddr l) '(lambda nlambda macro lexpr)) | |
370 | (null (cdr (last (caddr l))))) | |
371 | (princ '|(| $outport$) | |
372 | (princ 'def $outport$) | |
373 | (princ '| | $outport$) | |
374 | (princ (cadr l) $outport$) | |
375 | (terpri $outport$) | |
376 | (princ '| (| $outport$) | |
377 | (princ (caaddr l) $outport$) | |
378 | (princ '| | $outport$) | |
379 | (princ (cadaddr l) $outport$) | |
380 | (terpri $outport$) | |
381 | (mapc '(lambda (x) ($prdf x 4 0)) (cddaddr l)) | |
382 | (princ '|))| $outport$) | |
383 | t)))) | |
384 | ||
385 | (putprop 'def 'printdef 'printmacro) | |
386 | ||
387 | ; There's a version of this hacked into the printer (where it don't belong!) | |
388 | ; Note that it must NOT apply to things like (quote a b). | |
389 | ||
390 | ; | |
391 | ; adding printmacrochar so that it can be used by other read macros | |
392 | ; which create things of the form (tag lisp-expr) like quote does, | |
393 | ; I know this is restrictive but it is helpful in the frl source. - dhl. | |
394 | ; | |
395 | ; | |
396 | ||
397 | (def printmacrochar | |
398 | (lambda (macrochar l lmar rmar) | |
399 | (cond ((or (null (cdr l)) (cddr l)) nil) | |
400 | (t (princ macrochar $outport$) | |
401 | ($prdf (cadr l) (add1 lmar) rmar) | |
402 | t)))) | |
403 | ||
404 | (putprop 'quote '|'| 'printmacrochar) | |
405 | ||
406 | (def printaccross | |
407 | (lambda (l lmar rmar) | |
408 | (prog nil | |
409 | ; (*** this is needed to make sure the printmacros are executed) | |
410 | (princ '|(| $outport$) | |
411 | l: (cond ((null l)) | |
412 | ((atom l) (princ '|. | $outport$) (princ l $outport$)) | |
413 | (t ($prdf (car l) (nwritn $outport$) rmar) | |
414 | (setq l (cdr l)) | |
415 | (cond (l (princ '| | $outport$))) | |
416 | (go l:)))))) | |
417 |