![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to codeGen.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 codeGen.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / fp |
1.1 root 1: (setq SCCS-codeGen.l "@(#)codeGen.l 1.1 4/27/83")
2: ; FP interpreter/compiler
3: ; Copyright (c) 1982 Scott B. Baden
4: ; Berkeley, California
5:
6: ; Main Routine to do code generation
7:
8: (include specials.l)
9: (declare
10: (localf build_constr mName condit$fp alpha$fp insert$fp ti$fp while$fp)
11: )
12:
13: (defmacro getFform (xx)
14: `(implode (nreverse `(p f ,@(cdr (nreverse (explodec (cxr 0 ,xx))))))))
15:
16: (defun mName (name)
17: (cond ((atom name) `',name)
18: (t `',(getFform name))))
19:
20: (defun mNameI (name)
21: (cond ((atom name) name)
22: (t (getFform name))))
23:
24: (defun codeGen (ptree)
25: (cond ((atom ptree) `',ptree) ; primitive or
26: ; user defined
27:
28: ((eq (cxr 0 ptree) 'alpha$$) ; apply to all
29: (alpha$fp (cxr 1 ptree)))
30:
31: ((eq (cxr 0 ptree) 'insert$$) ; insert
32: (insert$fp (cxr 1 ptree)))
33:
34: ((eq (cxr 0 ptree) 'ti$$) ; tree insert
35: (ti$fp (cxr 1 ptree)))
36:
37: ((eq (cxr 0 ptree) 'select$$) ; selector
38: (let ((sel (cxr 1 ptree)))
39:
40: (If (zerop sel) ; No stats for errors
41: then `#'(lambda (x) (bottom))
42:
43: else
44:
45: `#'(lambda (x)
46: (cond ((not (listp x)) (bottom)))
47: (cond (DynTraceFlg (measSel ,sel x)))
48: ,(cond ((plusp sel)
49: `(If (greaterp ,sel (length x))
50: then (bottom)
51: else (nthelem ,sel x)))
52:
53:
54: ((minusp sel)
55: `(let ((len (length x)))
56: (If (greaterp ,(absval sel) len)
57: then (bottom)
58: else (nthelem (plus len ,(1+ sel)) x)))))))))
59:
60:
61:
62: ((eq (cxr 0 ptree) 'constant$$) ; constant
63: (let ((const (cxr 1 ptree)))
64: (If (eq const '?)
65: then `#'(lambda (x) (bottom))
66:
67: else
68:
69: `#'(lambda (x)
70: (cond (DynTraceFlg (measCons ,const x)))
71: ,const))))
72:
73:
74:
75: ((eq (cxr 0 ptree) 'condit$$) ; conditional
76: (condit$fp (cxr 1 ptree) (cxr 2 ptree) (cxr 3 ptree)))
77:
78: ((eq (cxr 0 ptree) 'while$$) ; while
79: (while$fp (cxr 1 ptree) (cxr 2 ptree)))
80:
81:
82: ((eq (cxr 0 ptree) 'compos$$) ; composition
83: (let ((cm1 (cxr 1 ptree))
84: (cm2 (cxr 2 ptree)))
85: `#'(lambda (x)
86: (cond (DynTraceFlg
87: (measComp ,(mName cm1) ,(mName cm2) x)))
88: (funcall ,(codeGen cm1)
89: (funcall ,(codeGen cm2)
90: x)))))
91:
92:
93: ((eq (cxr 0 ptree) 'constr$$)
94: (build_constr ptree)) ; construction
95:
96: (t 'error))) ; error, sb '?
97:
98:
99: ; build up the list of arguments for a construction
100:
101: (defun build_constr (pt)
102: (cond ((and (eq 2 (hunksize pt)) (null (cxr 1 pt)))
103: `#'(lambda (x) (cond (DynTraceFlg (measCons nil x))) nil))
104: (t
105: (do ((i 2 (1+ i))
106: (stat (list `,(mNameI (cxr 1 pt))))
107: (con (list (codeGen (cxr 1 pt)))))
108: ((greaterp i (1- (hunksize pt)))
109: (return
110: (funcall 'constr$fp con stat)))
111: (setq stat (append stat (list `,(mNameI (cxr i pt)))))
112: (setq con (append con (list (codeGen (cxr i pt)))))))))
113:
114:
115: ; generate a lisp function definition from an FP parse tree
116:
117: (defun put_fn (fn_name p_tree)
118: (untraceDel (extName fn_name))
119: (putd fn_name
120: `(lambda (x)
121: (cond (DynTraceFlg (IncrUDF ',fn_name x)))
122: (funcall ,(codeGen p_tree) x))))
123:
124:
125: ; The Functional forms
126: ;
127:
128:
129: ; fp conditional
130:
131: (def condit$fp
132: (lambda (Pptree Tptree Fptree)
133: (let ((test (codeGen Pptree))
134: (true (codeGen Tptree))
135: (false (codeGen Fptree)))
136:
137: (let ((q
138: `(lambda (x)
139: (cond (DynTraceFlg
140: (measCond
141: ,(mName Pptree)
142: ,(mName Tptree)
143: ,(mName Fptree) x)))
144:
145: (let ((z (funcall ,test x)))
146: (cond
147: ((eq 'T z) (funcall ,true x))
148: ((eq 'F z) (funcall ,false x))
149: (t (bottom)))))))
150: `(function ,q)))))
151:
152:
153:
154: ; construction
155:
156: (def constr$fp
157: (lexpr (v)
158: (let* ((vl (listify v))
159: (q
160: `(lambda (x)
161: (cond (DynTraceFlg
162: (measConstr ',(cadr vl) x)))
163: (let* ((savelevel level)
164: (h
165: (list
166: ,@(mapcar
167: #'(lambda
168: (y)
169: `(let ((r ,`(funcall ,y x)))
170: (setq level savelevel)
171: r))
172: (car vl)))))
173: (setq level savelevel)
174: h
175: ))))
176: `(function ,q))))
177:
178:
179:
180:
181: ; apply to all
182:
183: (def alpha$fp
184: (lambda (ptree)
185: (let* ((fn (codeGen ptree))
186: (q
187: `(lambda (x)
188: (cond (DynTraceFlg
189: (measAlph ,(mName ptree) x)))
190: (cond ((null x) nil)
191: ((not (listp x)) (bottom))
192: (t
193: (let* ((savelevel level)
194: (h
195: (mapcar
196: '(lambda (y)
197: (setq level savelevel)
198: (funcall ,fn y))
199: x)))
200:
201: (setq level savelevel)
202: h))))))
203: `(function ,q))))
204:
205:
206: ; insert
207:
208: (def insert$fp
209: (lambda (ptree)
210: (let* ((fn (codeGen ptree))
211: (q
212: `(lambda (x)
213: (cond (DynTraceFlg (measIns ,(mName ptree) x)))
214: (cond ((not (listp x)) (bottom))
215: ((null x)
216: (let ((ufn (get 'u-fnc ,fn)))
217: (cond
218: (ufn (funcall ufn))
219: (t (bottom)))))
220: (t (let ((v (reverse x)) (z nil))
221: (setq z (car v))
222: (setq v (cdr v))
223: (mapc '(lambda (y) (setq z (funcall ,fn (list y z)))) v)
224: z))))))
225: `(function ,q))))
226:
227:
228:
229:
230: (defun while$fp (pFn fFn)
231: (let* ((fn_p (codeGen pFn))
232: (fn_f (codeGen fFn))
233: (q
234: `(lambda (x)
235: (cond (DynTraceFlg
236: (measWhile ,(mName pFn) ,(mName fFn) x)))
237: (do
238: ((z (funcall ,fn_p x) (funcall ,fn_p rslt))
239: (rslt x))
240: ((eq 'F z) rslt)
241: (cond ((undefp z) (bottom)))
242: (setq rslt (funcall ,fn_f rslt))))))
243: `(function ,q)))
244:
245:
246:
247:
248: ; Tree insert
249:
250: (def ti$fp
251: (lambda (ptree)
252: (let* ((fn (codeGen ptree))
253: (q
254: `(lambda (x)
255: (cond (DynTraceFlg (measAi ,(mName ptree) x)))
256: (treeIns$fp ,fn x))))
257: `(function ,q))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.