(setq SCCS-codeGen.l "@(#)codeGen.l 4.1 12/14/82")
; FP interpreter/compiler
; Copyright (c) 1982 Scott B. Baden
; Main Routine to do code generation
(localf build_constr mName condit$fp alpha$fp insert$fp ti$fp while$fp)
`(implode (nreverse `(p f ,@(cdr (nreverse (explodec (cxr 0 ,xx))))))))
(cond ((atom name) `',name)
(cond ((atom ptree) `',ptree) ; primitive or
((eq (cxr 0 ptree) 'alpha$$) ; apply to all
(alpha$fp (cxr 1 ptree)))
((eq (cxr 0 ptree) 'insert$$) ; insert
(insert$fp (cxr 1 ptree)))
((eq (cxr 0 ptree) 'ti$$) ; tree insert
((eq (cxr 0 ptree) 'select$$) ; selector
(let ((sel (cxr 1 ptree)))
(If (zerop sel) ; No stats for errors
then `#'(lambda (x) (bottom))
(cond ((not (listp x)) (bottom)))
(cond (DynTraceFlg (measSel ,sel x)))
`(If (greaterp ,sel (length x))
(If (greaterp ,(absval sel) len)
else (nthelem (plus len ,(1+ sel)) x)))))))))
((eq (cxr 0 ptree) 'constant$$) ; constant
(let ((const (cxr 1 ptree)))
then `#'(lambda (x) (bottom))
(cond (DynTraceFlg (measCons ,const x)))
((eq (cxr 0 ptree) 'condit$$) ; conditional
(condit$fp (cxr 1 ptree) (cxr 2 ptree) (cxr 3 ptree)))
((eq (cxr 0 ptree) 'while$$) ; while
(while$fp (cxr 1 ptree) (cxr 2 ptree)))
((eq (cxr 0 ptree) 'compos$$) ; composition
(let ((cm1 (cxr 1 ptree))
(measComp ,(mName cm1) ,(mName cm2) x)))
((eq (cxr 0 ptree) 'constr$$)
(build_constr ptree)) ; construction
(t 'error))) ; error, sb '?
; build up the list of arguments for a construction
(cond ((and (eq 2 (hunksize pt)) (null (cxr 1 pt)))
`#'(lambda (x) (cond (DynTraceFlg (measCons nil x))) nil))
(stat (list `,(mNameI (cxr 1 pt))))
(con (list (codeGen (cxr 1 pt)))))
((greaterp i (1- (hunksize pt)))
(funcall 'constr$fp con stat)))
(setq stat (append stat (list `,(mNameI (cxr i pt)))))
(setq con (append con (list (codeGen (cxr i pt)))))))))
; generate a lisp function definition from an FP parse tree
(defun put_fn (fn_name p_tree)
(untraceDel (extName fn_name))
(cond (DynTraceFlg (IncrUDF ',fn_name x)))
(funcall ,(codeGen p_tree) x))))
(lambda (Pptree Tptree Fptree)
(let ((test (codeGen Pptree))
(false (codeGen Fptree)))
(let ((z (funcall ,test x)))
((eq 'T z) (funcall ,true x))
((eq 'F z) (funcall ,false x))
(measConstr ',(cadr vl) x)))
`(let ((r ,`(funcall ,y x)))
(let* ((fn (codeGen ptree))
(measAlph ,(mName ptree) x)))
((not (listp x)) (bottom))
(let* ((fn (codeGen ptree))
(cond (DynTraceFlg (measIns ,(mName ptree) x)))
(cond ((not (listp x)) (bottom))
(let ((ufn (get 'u-fnc ,fn)))
(t (let ((v (reverse x)) (z nil))
(mapc '(lambda (y) (setq z (funcall ,fn (list y z)))) v)
(defun while$fp (pFn fFn)
(let* ((fn_p (codeGen pFn))
(measWhile ,(mName pFn) ,(mName fFn) x)))
((z (funcall ,fn_p x) (funcall ,fn_p rslt))
(cond ((undefp z) (bottom)))
(setq rslt (funcall ,fn_f rslt))))))
(let* ((fn (codeGen ptree))
(cond (DynTraceFlg (measAi ,(mName ptree) x)))