1 (setq SCCS-fpMain.l "@(#)fpMain.l 1.2 10/08/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 '?)) 224