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