Return to fpMain.l CVS log

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

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

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