1 (setq SCCS-codeGen.l "@(#)codeGen.l 1.1 04/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)))) 258