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) 05/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)))) 263