Return to codeGen.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / fp

Annotation of 42BSD/ucb/fp/codeGen.l, revision 1.1

1.1     ! root        1: (setq SCCS-codeGen.l "@(#)codeGen.l    1.1     4/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))))

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.