112065Sbaden ; FP interpreter/compiler 212065Sbaden ; Copyright (c) 1982 Scott B. Baden 312065Sbaden ; Berkeley, California 4*21724Sdist ; 5*21724Sdist ; Copyright (c) 1982 Regents of the University of California. 6*21724Sdist ; All rights reserved. The Berkeley software License Agreement 7*21724Sdist ; specifies the terms and conditions for redistribution. 8*21724Sdist ; 9*21724Sdist (setq SCCS-codeGen.l "@(#)codeGen.l 5.1 (Berkeley) 05/31/85") 1012065Sbaden 1112065Sbaden ; Main Routine to do code generation 1212065Sbaden 1312065Sbaden (include specials.l) 1412065Sbaden (declare 1512065Sbaden (localf build_constr mName condit$fp alpha$fp insert$fp ti$fp while$fp) 1612065Sbaden ) 1712065Sbaden 1812065Sbaden (defmacro getFform (xx) 1912065Sbaden `(implode (nreverse `(p f ,@(cdr (nreverse (explodec (cxr 0 ,xx)))))))) 2012065Sbaden 2112065Sbaden (defun mName (name) 2212065Sbaden (cond ((atom name) `',name) 2312065Sbaden (t `',(getFform name)))) 2412065Sbaden 2512065Sbaden (defun mNameI (name) 2612065Sbaden (cond ((atom name) name) 2712065Sbaden (t (getFform name)))) 2812065Sbaden 2912065Sbaden (defun codeGen (ptree) 3012065Sbaden (cond ((atom ptree) `',ptree) ; primitive or 3112065Sbaden ; user defined 3212065Sbaden 3312065Sbaden ((eq (cxr 0 ptree) 'alpha$$) ; apply to all 3412065Sbaden (alpha$fp (cxr 1 ptree))) 3512065Sbaden 3612065Sbaden ((eq (cxr 0 ptree) 'insert$$) ; insert 3712065Sbaden (insert$fp (cxr 1 ptree))) 3812065Sbaden 3912065Sbaden ((eq (cxr 0 ptree) 'ti$$) ; tree insert 4012065Sbaden (ti$fp (cxr 1 ptree))) 4112065Sbaden 4212065Sbaden ((eq (cxr 0 ptree) 'select$$) ; selector 4312065Sbaden (let ((sel (cxr 1 ptree))) 4412065Sbaden 4512065Sbaden (If (zerop sel) ; No stats for errors 4612065Sbaden then `#'(lambda (x) (bottom)) 4712065Sbaden 4812065Sbaden else 4912065Sbaden 5012065Sbaden `#'(lambda (x) 5112065Sbaden (cond ((not (listp x)) (bottom))) 5212065Sbaden (cond (DynTraceFlg (measSel ,sel x))) 5312065Sbaden ,(cond ((plusp sel) 5412065Sbaden `(If (greaterp ,sel (length x)) 5512065Sbaden then (bottom) 5612065Sbaden else (nthelem ,sel x))) 5712065Sbaden 5812065Sbaden 5912065Sbaden ((minusp sel) 6012065Sbaden `(let ((len (length x))) 6112065Sbaden (If (greaterp ,(absval sel) len) 6212065Sbaden then (bottom) 6312065Sbaden else (nthelem (plus len ,(1+ sel)) x))))))))) 6412065Sbaden 6512065Sbaden 6612065Sbaden 6712065Sbaden ((eq (cxr 0 ptree) 'constant$$) ; constant 6812065Sbaden (let ((const (cxr 1 ptree))) 6912065Sbaden (If (eq const '?) 7012065Sbaden then `#'(lambda (x) (bottom)) 7112065Sbaden 7212065Sbaden else 7312065Sbaden 7412065Sbaden `#'(lambda (x) 7512065Sbaden (cond (DynTraceFlg (measCons ,const x))) 7612065Sbaden ,const)))) 7712065Sbaden 7812065Sbaden 7912065Sbaden 8012065Sbaden ((eq (cxr 0 ptree) 'condit$$) ; conditional 8112065Sbaden (condit$fp (cxr 1 ptree) (cxr 2 ptree) (cxr 3 ptree))) 8212065Sbaden 8312065Sbaden ((eq (cxr 0 ptree) 'while$$) ; while 8412065Sbaden (while$fp (cxr 1 ptree) (cxr 2 ptree))) 8512065Sbaden 8612065Sbaden 8712065Sbaden ((eq (cxr 0 ptree) 'compos$$) ; composition 8812065Sbaden (let ((cm1 (cxr 1 ptree)) 8912065Sbaden (cm2 (cxr 2 ptree))) 9012065Sbaden `#'(lambda (x) 9112065Sbaden (cond (DynTraceFlg 9212065Sbaden (measComp ,(mName cm1) ,(mName cm2) x))) 9312065Sbaden (funcall ,(codeGen cm1) 9412065Sbaden (funcall ,(codeGen cm2) 9512065Sbaden x))))) 9612065Sbaden 9712065Sbaden 9812065Sbaden ((eq (cxr 0 ptree) 'constr$$) 9912065Sbaden (build_constr ptree)) ; construction 10012065Sbaden 10112065Sbaden (t 'error))) ; error, sb '? 10212065Sbaden 10312065Sbaden 10412065Sbaden ; build up the list of arguments for a construction 10512065Sbaden 10612065Sbaden (defun build_constr (pt) 10712065Sbaden (cond ((and (eq 2 (hunksize pt)) (null (cxr 1 pt))) 10812065Sbaden `#'(lambda (x) (cond (DynTraceFlg (measCons nil x))) nil)) 10912065Sbaden (t 11012065Sbaden (do ((i 2 (1+ i)) 11112065Sbaden (stat (list `,(mNameI (cxr 1 pt)))) 11212065Sbaden (con (list (codeGen (cxr 1 pt))))) 11312065Sbaden ((greaterp i (1- (hunksize pt))) 11412065Sbaden (return 11512065Sbaden (funcall 'constr$fp con stat))) 11612065Sbaden (setq stat (append stat (list `,(mNameI (cxr i pt))))) 11712065Sbaden (setq con (append con (list (codeGen (cxr i pt))))))))) 11812065Sbaden 11912065Sbaden 12012065Sbaden ; generate a lisp function definition from an FP parse tree 12112065Sbaden 12212065Sbaden (defun put_fn (fn_name p_tree) 12312065Sbaden (untraceDel (extName fn_name)) 12412065Sbaden (putd fn_name 12512065Sbaden `(lambda (x) 12612065Sbaden (cond (DynTraceFlg (IncrUDF ',fn_name x))) 12712065Sbaden (funcall ,(codeGen p_tree) x)))) 12812065Sbaden 12912065Sbaden 13012065Sbaden ; The Functional forms 13112065Sbaden ; 13212065Sbaden 13312065Sbaden 13412065Sbaden ; fp conditional 13512065Sbaden 13612065Sbaden (def condit$fp 13712065Sbaden (lambda (Pptree Tptree Fptree) 13812065Sbaden (let ((test (codeGen Pptree)) 13912065Sbaden (true (codeGen Tptree)) 14012065Sbaden (false (codeGen Fptree))) 14112065Sbaden 14212065Sbaden (let ((q 14312065Sbaden `(lambda (x) 14412065Sbaden (cond (DynTraceFlg 14512065Sbaden (measCond 14612065Sbaden ,(mName Pptree) 14712065Sbaden ,(mName Tptree) 14812065Sbaden ,(mName Fptree) x))) 14912065Sbaden 15012065Sbaden (let ((z (funcall ,test x))) 15112065Sbaden (cond 15212065Sbaden ((eq 'T z) (funcall ,true x)) 15312065Sbaden ((eq 'F z) (funcall ,false x)) 15412065Sbaden (t (bottom))))))) 15512065Sbaden `(function ,q))))) 15612065Sbaden 15712065Sbaden 15812065Sbaden 15912065Sbaden ; construction 16012065Sbaden 16112065Sbaden (def constr$fp 16212065Sbaden (lexpr (v) 16312065Sbaden (let* ((vl (listify v)) 16412065Sbaden (q 16512065Sbaden `(lambda (x) 16612065Sbaden (cond (DynTraceFlg 16712065Sbaden (measConstr ',(cadr vl) x))) 16812065Sbaden (let* ((savelevel level) 16912065Sbaden (h 17012065Sbaden (list 17112065Sbaden ,@(mapcar 17212065Sbaden #'(lambda 17312065Sbaden (y) 17412065Sbaden `(let ((r ,`(funcall ,y x))) 17512065Sbaden (setq level savelevel) 17612065Sbaden r)) 17712065Sbaden (car vl))))) 17812065Sbaden (setq level savelevel) 17912065Sbaden h 18012065Sbaden )))) 18112065Sbaden `(function ,q)))) 18212065Sbaden 18312065Sbaden 18412065Sbaden 18512065Sbaden 18612065Sbaden ; apply to all 18712065Sbaden 18812065Sbaden (def alpha$fp 18912065Sbaden (lambda (ptree) 19012065Sbaden (let* ((fn (codeGen ptree)) 19112065Sbaden (q 19212065Sbaden `(lambda (x) 19312065Sbaden (cond (DynTraceFlg 19412065Sbaden (measAlph ,(mName ptree) x))) 19512065Sbaden (cond ((null x) nil) 19612065Sbaden ((not (listp x)) (bottom)) 19712065Sbaden (t 19812065Sbaden (let* ((savelevel level) 19912065Sbaden (h 20012065Sbaden (mapcar 20112065Sbaden '(lambda (y) 20212065Sbaden (setq level savelevel) 20312065Sbaden (funcall ,fn y)) 20412065Sbaden x))) 20512065Sbaden 20612065Sbaden (setq level savelevel) 20712065Sbaden h)))))) 20812065Sbaden `(function ,q)))) 20912065Sbaden 21012065Sbaden 21112065Sbaden ; insert 21212065Sbaden 21312065Sbaden (def insert$fp 21412065Sbaden (lambda (ptree) 21512065Sbaden (let* ((fn (codeGen ptree)) 21612065Sbaden (q 21712065Sbaden `(lambda (x) 21812065Sbaden (cond (DynTraceFlg (measIns ,(mName ptree) x))) 21912065Sbaden (cond ((not (listp x)) (bottom)) 22012065Sbaden ((null x) 22112065Sbaden (let ((ufn (get 'u-fnc ,fn))) 22212065Sbaden (cond 22312065Sbaden (ufn (funcall ufn)) 22412065Sbaden (t (bottom))))) 22512065Sbaden (t (let ((v (reverse x)) (z nil)) 22612065Sbaden (setq z (car v)) 22712065Sbaden (setq v (cdr v)) 22812065Sbaden (mapc '(lambda (y) (setq z (funcall ,fn (list y z)))) v) 22912065Sbaden z)))))) 23012065Sbaden `(function ,q)))) 23112065Sbaden 23212065Sbaden 23312065Sbaden 23412065Sbaden 23512065Sbaden (defun while$fp (pFn fFn) 23612065Sbaden (let* ((fn_p (codeGen pFn)) 23712065Sbaden (fn_f (codeGen fFn)) 23812065Sbaden (q 23912065Sbaden `(lambda (x) 24012065Sbaden (cond (DynTraceFlg 24112065Sbaden (measWhile ,(mName pFn) ,(mName fFn) x))) 24212065Sbaden (do 24312065Sbaden ((z (funcall ,fn_p x) (funcall ,fn_p rslt)) 24412065Sbaden (rslt x)) 24512065Sbaden ((eq 'F z) rslt) 24612065Sbaden (cond ((undefp z) (bottom))) 24712065Sbaden (setq rslt (funcall ,fn_f rslt)))))) 24812065Sbaden `(function ,q))) 24912065Sbaden 25012065Sbaden 25112065Sbaden 25212065Sbaden 25312065Sbaden ; Tree insert 25412065Sbaden 25512065Sbaden (def ti$fp 25612065Sbaden (lambda (ptree) 25712065Sbaden (let* ((fn (codeGen ptree)) 25812065Sbaden (q 25912065Sbaden `(lambda (x) 26012065Sbaden (cond (DynTraceFlg (measAi ,(mName ptree) x))) 26112065Sbaden (treeIns$fp ,fn x)))) 26212065Sbaden `(function ,q)))) 263