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