Return to codeGen.l CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / fp / fp.vax

Annotation of 43BSDTahoe/ucb/fp/fp.vax/codeGen.l, revision 1.1

1.1     ! root        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) 5/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))))

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