![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fpPP.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / fp|
Return to fpPP.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / fp |
1.1 root 1: ; FP interpreter/compiler
2: ; Copyright (c) 1982 Scott B. Baden
3: ; Berkeley, California
4: ;
5: ; Copyright (c) 1982 Regents of the University of California.
6: ; All rights reserved. The Berkeley software License Agreement
7: ; specifies the terms and conditions for redistribution.
8: ;
9: (setq SCCS-fpPP.l "@(#)fpPP.l 5.1 (Berkeley) 5/31/85")
10:
11: ;; pretty printer for fp -- snarfed from FRANZ LISP
12:
13: (include specials.l)
14:
15: (declare (special fpPParm1 fpPParm2 lAngle rAngle))
16:
17: ; printRet is like print yet it returns the value printed,
18: ; this is used by fpPP.
19:
20: (def printRet
21: (macro ($l$)
22: `(progn
23: (let ((z ,@(cdr $l$)))
24: (cond ((null z) (patom "<>"))
25: (t
26: (print ,@(cdr $l$))))))))
27:
28:
29: (def fpPP
30: (lambda (x)
31: (terpri)
32: (prDF x 0 0)
33: (terpri)))
34:
35:
36: (setq fpPParm1 50 fpPParm2 100)
37:
38: ; -DNC These "prettyprinter parameters" are used to decide when we should
39: ; quit printing down the right margin and move back to the left -
40: ; Do it when the leftmargin > fpPParm1 and there are more than fpPParm2
41: ; more chars to print in the expression
42:
43:
44:
45: (declare (special rmar))
46:
47: (def prDF
48: (lambda (l lmar rmar)
49: (prog nil
50: ;
51: ; - DNC - Here we try to fix the tendency to print a
52: ; thin column down the right margin by allowing it
53: ; to move back to the left if necessary.
54: ;
55: (cond ((and (>& lmar fpPParm1) (>& (flatc l (1+ fpPParm2)) fpPParm2))
56: (terpri)
57: (patom "; <<<<< start back on the left <<<<<")
58: (prDF l 5 0)
59: (terpri)
60: (patom "; >>>>> continue on the right >>>>>")
61: (terpri)
62: (return nil)))
63: (tab lmar)
64: a (cond
65: ((or (not (dtpr l))
66: ; (*** at the moment we just punt hunks etc)
67: ;(and (atom (car l)) (atom (cdr l)))
68: )
69: (return (printRet l)))
70: ((<& (+ rmar (flatc l (charcnt poport)))
71: (charcnt poport))
72: ;
73: ; This is just a heuristic - if print can fit it in then figure that
74: ; the printmacros won't hurt. Note that despite the pretentions there
75: ; is no guarantee that everything will fit in before rmar - for example
76: ; atoms (and now even hunks) are just blindly printed. - DNC
77: ;
78: (printAccross l lmar rmar))
79: ((and ($patom1 lAngle)
80: (atom (car l))
81: (not (atom (cdr l)))
82: (not (atom (cddr l))))
83: (prog (c)
84: (printRet (car l))
85: ($patom1 '" ")
86: (setq c (nwritn))
87: a (prD1 (cdr l) c)
88: (cond
89: ((not (atom (cdr (setq l (cdr l)))))
90: (terpri)
91: (go a)))))
92: (t
93: (prog (c)
94: (setq c (nwritn))
95: a (prD1 l c)
96: (cond
97: ((not (atom (setq l (cdr l))))
98: (terpri)
99: (go a))))))
100: b ($patom1 rAngle))))
101:
102:
103: (def prD1
104: (lambda (l n)
105: (prog nil
106: (prDF (car l)
107: n
108: (cond ((null (setq l (cdr l))) (|1+| rmar))
109: ((atom l) (setq n nil) (plus 4 rmar (pntlen l)))
110: (t rmar)))
111:
112: ; The last arg to prDF is the space needed for the suffix
113: ; Note that this is still not really right - if the prefix
114: ; takes several lines one would like to use the old rmar
115: ; until the last line where the " . mumble" goes.
116: )))
117:
118:
119: (def printAccross
120: (lambda (l lmar rmar)
121: (prog nil
122: ; this is needed to make sure the printmacros are executed
123: (princ '|<|)
124: l: (cond ((null l))
125: (t (prDF (car l) (nwritn) rmar)
126: (setq l (cdr l))
127: (cond (l (princ '| |)))
128: (go l:))))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.