Return to fpMain.l CVS log

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

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

1.1     ! root        1: (setq SCCS-fpMain.l "@(#)fpMain.l      1.2     10/8/83")
        !             2: ;  FP interpreter/compiler
        !             3: ;  Copyright (c) 1982  Scott B. Baden
        !             4: ;  Berkeley, California
        !             5: 
        !             6: ; Main routine to start up FP
        !             7: 
        !             8: (include specials.l)
        !             9: (declare (special arg parse_tree)
        !            10:   (localf syntaxErr synErrMsg last_cr p_indic display rtime doExit)
        !            11:   )
        !            12: 
        !            13: ; may ask for debug output,
        !            14: ; specifiy character set, only ASCII (asc) supported at this time.
        !            15: ; exit to shell if invoked  from it.
        !            16: 
        !            17: (defun fpMain (debug from_shell)       
        !            18:   
        !            19:   (do ((arg nil)
        !            20:        (parse_tree (*catch '(parse$err end_condit end_while)  (parse 'top_lev))
        !            21:                   (*catch '(parse$err  end_condit end_while) (parse 'top_lev))))
        !            22:       
        !            23:       ; exit if an EOF has been entered from the terminal
        !            24:       ; (and it was the only character entered on the line)
        !            25:       
        !            26:       ((and (eq parse_tree 'eof$$) (null infile))
        !            27:        (terpri) 
        !            28:        (doExit from_shell))     ; in any case exit
        !            29:       
        !            30:       ; if the EOF was from a file close it and then accept
        !            31:       ; input from terminal again
        !            32:       
        !            33:       (cond 
        !            34:        ((not (eq parse_tree 'eof$$))
        !            35:        (cond (debug (print parse_tree) 
        !            36:                     (terpri)))
        !            37:        (cond
        !            38:         ((not (eq parse_tree 'cmd$$))
        !            39:          (cond 
        !            40:           ((not (listp parse_tree))
        !            41:            (let
        !            42:             ((defn (put_fn fn_name parse_tree)))       ; define the function
        !            43:             (cond (in_def
        !            44:                    (patom "{")
        !            45:                    (patom (setq usr_fn_name
        !            46:                                 (implode 
        !            47:                                  (nreverse (cdddr (nreverse (explode fn_name)))))))
        !            48:                    (patom "}") (terpri)
        !            49:                    (putprop 'sources in_buf usr_fn_name)))
        !            50:             (cond ((and debug in_def) (pp fn_name))))
        !            51:            
        !            52:            ; read in an FP sequence once a colon (apply) has been detected
        !            53:            
        !            54:            (cond ((not in_def)
        !            55:                   (cond ((and (null infile) ptport)
        !            56:                          (do
        !            57:                           ((c (tyipeek) (tyipeek)))
        !            58:                           ((or (null (memq c #.whiteSpace))))
        !            59:                           (Tyi))))
        !            60:                   (setq arg (*catch 'parse$err  (get_obj nil)))
        !            61:                   
        !            62:                   (cond ((find 'err$$ arg)
        !            63:                          (syntaxErr))
        !            64:                         ((undefp arg)
        !            65:                          (terpri) (patom '?) (terpri))
        !            66:                         (t  
        !            67:                          (let ((sPlist
        !            68:                                 (If DynTraceFlg then
        !            69:                                     (copy (plist 'Measures)) else nil))
        !            70:                                (wcTime1 (sys:time))
        !            71:                                (time1 (ptime))
        !            72:                                (rslt (*catch 'bottom$up (funcall fn_name arg)))
        !            73:                                (time2 (ptime))
        !            74:                                (wcTime2 (sys:time)))
        !            75:                               
        !            76:                               (fpPP rslt)
        !            77: 
        !            78:                               (If (and DynTraceFlg (undefp rslt)) then (setplist 'Measures sPlist))
        !            79:                               (cond (timeIt
        !            80:                                      (let ((gcTime (diff (cadr time2) (cadr time1))))
        !            81:                                           (msg N "cpu + gc [wc] = ")
        !            82:                                           (rtime  (diff (diff (car time2) (car time1)) gcTime) 60.0)
        !            83:                                           (patom " + ")
        !            84:                                           (rtime  gcTime 60.0)
        !            85:                                           (patom " [")
        !            86:                                           (rtime (diff wcTime2 wcTime1) 1.0)
        !            87:                                           (msg "]"))
        !            88:                                      (msg (N 2))))))))))
        !            89:           
        !            90:           (t (syntaxErr) ))))))
        !            91:       
        !            92:       
        !            93:       (cond (in_def  (setq fn_name 'tmp$$)))
        !            94:       
        !            95:       (cond ((and infile (eq parse_tree 'eof$$))
        !            96:             (patom "      ") (close infile) (setq infile nil))
        !            97:            
        !            98:            (t (cond ((and (null infile) (not (eq parse_tree 'eof$$)))
        !            99:                      (patom "      ")))))
        !           100:       
        !           101:       (setq level 0)
        !           102:       (setq in_buf nil)
        !           103:       (setq in_def nil)))
        !           104: 
        !           105: 
        !           106: ; Display a LISP list as an equivalent FP sequence
        !           107: 
        !           108: (defun display (obj)
        !           109:   (cond ((null obj) (patom "<>"))
        !           110:        ((atom obj) (patom obj))
        !           111:        ((listp obj)
        !           112:         (patom "<")
        !           113:         (maplist 
        !           114:          '(lambda (x) 
        !           115:                   (display (car x))
        !           116:                   (cond ((not (onep (length x))) (patom " ")))) obj)
        !           117:         (patom ">"))))
        !           118: 
        !           119: ; Form a character string  of a LISP list as an equivalent FP sequence
        !           120: 
        !           121: (defun put_obj (obj)
        !           122:   (cond ((null obj) "<>")
        !           123:        ((atom obj) obj)
        !           124:        ((listp obj)
        !           125:         (cond ((onep (length obj))
        !           126:                (concat "<" (put_obj (car obj)) ">"))
        !           127:               (t (do
        !           128:                   ((xx obj (cdr xx))
        !           129:                    (zz t nil)
        !           130:                    (yy "<"))
        !           131:                   ((zerop (length xx)) (concat yy ">"))
        !           132:                   (cond ((not zz) (setq yy (concat yy " "))))
        !           133:                   (setq yy (concat yy (put_obj (car xx))))))))))
        !           134: 
        !           135: 
        !           136: 
        !           137: (defun rtime (time scale)
        !           138:   (patom (quotient (float (fix (product 100 (quotient time scale))))
        !           139:                   100.0)))
        !           140: 
        !           141: (defun doExit (exitCond)
        !           142:   (cond (exitCond
        !           143:         (dontLoseStats)
        !           144:         (and (portp 'traceport) (close traceport)) ; if traceport is open
        !           145:         (and ptport (close ptport))                ; if script port is open
        !           146:         (exit))))
        !           147: 
        !           148: 
        !           149: (defun syntaxErr nil
        !           150:   (let ((piport infile)
        !           151:        (tbuf (ncons nil)))
        !           152:        (cond ((and in_def (eq #/} (car in_buf)))
        !           153:              (do ((c (Tyi) (Tyi)))
        !           154:                  ((memq c '(-1 #.CR))))
        !           155:              (synErrMsg)
        !           156:              (p_indic)
        !           157:              )
        !           158:             
        !           159:             (t (cond (in_def
        !           160:                       (cond ((and 
        !           161:                               (eq #.CR
        !           162:                                   (do ((c (tyipeek) (tyipeek))
        !           163:                                        (e nil))
        !           164:                                       ((memq c '(-1 #/} #.CR))
        !           165:                                        (If (eq c #/}) then 
        !           166:                                            (progn
        !           167:                                             (tconc tbuf c)
        !           168:                                             (setq e (Tyi)))
        !           169:                                            
        !           170:                                            else
        !           171:                                            
        !           172:                                            (If (eq c #.CR) then
        !           173:                                                (setq e (Tyi))))
        !           174: 
        !           175:                                        (synErrMsg)
        !           176:                                        (mapcar 'p_strng (car tbuf))
        !           177:                                        (p_indic)
        !           178:                                        e)
        !           179:                                       (tconc tbuf (Tyi))))
        !           180:                               infile)
        !           181:                              
        !           182:                              (do ((c (tyipeek) (tyipeek))
        !           183:                                   (tbuf (ncons nil)))
        !           184:                                  ((memq c '(-1 #/}))
        !           185:                                   (If (eq c #/})
        !           186:                                   then (tconc tbuf (Tyi)))
        !           187:                                   (mapcar 'p_strng (car tbuf))
        !           188:                                   (terpri)
        !           189:                                   (If (eq c #/}) then
        !           190:                                       (do ((c (Tyi) (Tyi)))
        !           191:                                           ((memq c '(-1 #.CR)))))
        !           192:                                   )
        !           193:                                  
        !           194:                                  (tconc tbuf (Tyi))))))
        !           195:                      
        !           196:                      (t
        !           197:                       (do ((c (tyipeek) (tyipeek)))
        !           198:                           ((memq c '(-1 #.CR))
        !           199:                            (Tyi)
        !           200:                            (synErrMsg)
        !           201:                            (mapcar 'p_strng (car tbuf))
        !           202:                            (p_indic))
        !           203:                           (tconc tbuf (Tyi)))))))
        !           204:        ))
        !           205: 
        !           206: (defun synErrMsg nil
        !           207:   (msg N "Syntax Error:" 
        !           208:        (N 2))
        !           209:   (mapcar 'p_strng (reverse in_buf)))
        !           210: 
        !           211: 
        !           212: (defun p_indic nil
        !           213:   (msg N (B (length (cdr (last_cr (reverse in_buf))))) "^" N)
        !           214:   (If (null infile) then (terpr)))
        !           215: 
        !           216: (defun last_cr (zy)
        !           217:   (cond ((null (memq #.CR zy)) zy) (t (last_cr (cdr (memq #.CR zy))))))
        !           218: 
        !           219: ; throw bottom to the next level
        !           220: ; This shortens the compiled code
        !           221: 
        !           222: (defun bottom nil
        !           223:   (*throw 'bottom$up '?))

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