![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to pp.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib|
Return to pp.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 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:
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:
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:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.