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) 05/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 '?)) 229