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-utils.l "@(#)utils.l 5.1 (Berkeley) 05/31/85") 10 11 ; FP command processor 12 13 (include specials.l) 14 (declare (localf u$print_fn intName pfn makeroom 15 getCmdLine) (special cmdLine codePort)) 16 17 (defun get_cmd nil 18 (prog (cmdLine command) 19 (setq cmdLine (getCmdLine)) 20 (cond ((null cmdLine) (msg N "Illegal Command" N) 21 (return 'cmd$$))) 22 (setq command (car cmdLine)) 23 (setq cmdLine (cdr cmdLine)) 24 (let ((cmdFn (get 'cp$ command))) 25 (cond ((null cmdFn) (msg N "Illegal Command" N)) 26 (t (funcall cmdFn) (return 'cmd$$)))) 27 (return 'cmd$$))) 28 29 (defun getCmdLine nil 30 (do ((names nil) (name$ nil) 31 (c (tyipeek) (tyipeek))) 32 ((eq c #.CR) 33 (Tyi) 34 (cond (name$ 35 (nreverse (cons (implode (nreverse name$)) names))) 36 (t (nreverse names)))) 37 (cond ((memq c #.blankOrTab) 38 (cond (name$ 39 (setq names (cons (implode (nreverse name$)) names)) 40 (setq name$ nil))) 41 (Tyi)) 42 43 (t (setq name$ (cons (Tyi) name$)))))) 44 45 46 (defun (cp$ load) nil 47 (cond (cmdLine 48 (let ((h (car cmdLine))) 49 (cond 50 ((null (setq infile (car (errset (infile (concat h '.fp)) nil)))) 51 (cond 52 ((null (setq infile (car (errset (infile h) nil)))) 53 (msg N "Can't open file" N))))))) 54 (t (msg N "must supply a file" N)))) 55 56 57 58 (defun (cp$ csave) nil 59 (If cmdLine then 60 (setq codePort (car (errset (outfile (car cmdLine)) nil))) 61 (If (null codePort) then 62 (msg N "Can't open file" N) 63 64 else 65 66 (msg (P codePort) "(declare (special DynTraceFlg level))" N) 67 (do ((l (plist 'sources) (cddr l))) 68 69 ((null l) (msg (P codePort) N) (close codePort)) 70 71 (apply 'pp (list '(P codePort) (concat (car l) '_fp))) 72 (msg (P codePort) N) 73 (msg (P codePort) 74 "(eval-when (load) (putprop 'sources '" 75 (cadr l) 76 " '" (car l) 77 "))" N)) 78 ) 79 else 80 81 (msg "must supply a file" N))) 82 83 (defun (cp$ fsave) nil 84 (If cmdLine then 85 (setq codePort (car (errset (outfile (car cmdLine)) nil))) 86 (If (null codePort) then 87 (msg N "Can't open file" N) 88 89 else 90 91 (msg (P codePort) "(declare (special DynTraceFlg level))" N) 92 (do ((l (plist 'sources) (cddr l))) 93 94 ((null l) (msg (P codePort) N) (close codePort)) 95 96 (let ((fName (concat (car l) '_fp))) 97 (msg (P codePort) 98 N "(def " fName N (getd `,fName) ")" N)) 99 100 (msg (P codePort) 101 "(eval-when (load) (putprop 'sources '" 102 (cadr l) 103 " '" (car l) 104 "))" N)) 105 ) 106 else 107 108 (msg "must supply a file" N))) 109 110 111 (defun (cp$ cload) nil 112 (If cmdLine then 113 (let ((codeFile (car cmdLine))) 114 (If (probef codeFile) 115 then (load codeFile) 116 else (If (probef (concat codeFile ".o")) 117 then (load (concat codeFile ".o")) 118 else (msg N codeFile ": No such File" N)))) 119 else (msg "must supply a file" N))) 120 121 122 (defun (cp$ fns) nil 123 (terpri) 124 (let ((z (plist 'sources))) 125 (cond ((null z) nil) 126 (t (do ((slist 127 (sort 128 (do ((l z (cddr l)) 129 (ls nil)) 130 ((null l) ls) 131 (setq ls (cons (car l) ls))) 132 'alphalessp) 133 (cdr slist)) 134 135 (trFns (mapcar 'extName TracedFns))) 136 137 ((null slist) (terpri) (terpri)) 138 139 (let ((oldn (nwritn)) 140 (fnName (car slist))) 141 (cond ((memq fnName trFns) (setq fnName (concat 142 fnName 143 '@)))) 144 (let ((nl (makeroom 80 fnName))) 145 (patom fnName) 146 (let ((vv (- 13 (mod (- (nwritn) 147 (cond (nl 0) (t oldn))) 12)))) 148 (cond ((lessp 80 (+ (nwritn) vv)) (terpri)) 149 (t 150 (mapcar 151 '(lambda (nil) (tyo #.BLANK)) (iota$fp vv)))))))))))) 152 (defun (cp$ pfn) nil 153 (mapcar '(lambda (u) (terpri) (u$print_fn u) (terpri)) cmdLine)) 154 155 (defun u$print_fn (fn_name) 156 (let ((source nil)) 157 (setq source (get 'sources fn_name)) 158 (cond ((null source) (msg fn_name " is not defined")) 159 (t (mapcar 'p_strng (reverse source)))) 160 (terpri))) 161 162 (defun (cp$ save) nil 163 (cond (cmdLine 164 (cond ((null (setq outfile (car (errset (outfile (car cmdLine)) nil)))) 165 (msg N "Can't open file" N)) 166 (t (let ((poport outfile)) 167 (terpri) 168 (do ((l (plist 'sources) (cddr l))) 169 ((null l) (terpri) (terpri)) 170 (mapcar 'p_strng (reverse (cadr l))) 171 (terpri) 172 (terpri))) 173 (setq outfile nil)))) 174 (t (msg N "You must supply a file" N)))) 175 176 ; This is called by delete and function definition 177 ; in case the function to be deleted is being traced. 178 ; It handles the traced-expr property hassles. 179 180 (defun untraceDel (name) 181 (let* ((fnName (concat name '_fp)) 182 (tmp (get fnName 'traced-expr))) 183 184 ; Do nothing if fn isn't being traced 185 (cond ((null tmp)) 186 (t (remprop fnName 'traced-expr) 187 (setq TracedFns (remove fnName TracedFns)))))) 188 189 (defun (cp$ delete) nil 190 (mapcar 'dfn cmdLine)) 191 192 (defun dfn (fn) 193 (cond ((null (get 'sources fn)) (msg fn ": No such fn" N)) 194 (t (remprop 'sources fn) 195 (remob (concat fn '_fp)) 196 (untraceDel fn)))) 197 198 (defun (cp$ timer) nil 199 (let ((d (car cmdLine))) 200 (cond ((eq d 'on) (setq timeIt t) 201 (msg N "Timing applications turned on" N)) 202 ((eq d 'off) (setq timeIt nil) 203 (msg N "Timing applications turned off" N)) 204 (t (msg N "Bad Timing Mode" N))) 205 (terpri))) 206 207 (defun (cp$ script) nil 208 (let ((cmd (get 'scriptCmd (car cmdLine)))) 209 (cond (cmd (funcall cmd)) 210 (t (msg N "Bad Script Mode" N))) 211 (terpri))) 212 213 214 (defun (scriptCmd open) nil 215 (let ((nScriptName (cadr cmdLine))) 216 (cond ((null nScriptName) (msg N "No Script-file specified" N)) 217 (t 218 (let ((Nptport (outfile nScriptName))) 219 (cond ((null Nptport) (msg N "Can't open Script-file" N)) 220 (t (msg N "Opening Script File" N) 221 (and ptport (close ptport)) 222 (setq ptport Nptport)))))))) 223 224 225 (defun (scriptCmd append) nil 226 (let ((nScriptName (cadr cmdLine))) 227 (cond (ptport (patom nScriptName ptport))) 228 (let ((Nptport (outfile nScriptName 'append))) 229 (cond ((null Nptport) (msg N "Can't open Script-file" N)) 230 (t (msg N "Appending to Script File" N) 231 (and ptport (close ptport)) 232 (setq ptport Nptport)))))) 233 234 (defun (scriptCmd close) nil 235 (close ptport) 236 (setq ptport nil) 237 (msg N "Closing Script File" N)) 238 239 (defun (cp$ help) nil 240 (terpri) 241 (patom " Commands are:") 242 (terpri) 243 (do 244 ((z (plist 'helpCmd) (cddr z))) 245 ((null z)(terpri)) 246 (terpri) 247 (patom (cadr z)))) 248 249 250 (defun (cp$ stats) nil 251 (let ((statOption (get 'statFn (car cmdLine)))) 252 (setq cmdLine (cdr cmdLine)) 253 (cond (statOption (funcall statOption)) 254 (t 255 (msg N "Bad Stats Option" N) 256 (terpri))))) 257 258 (defun (statFn on) nil 259 (terpri) 260 (msg N "Stats collection turned on" N) 261 (terpri) 262 (terpri) 263 (startDynStats)) 264 265 266 (defun startDynStats nil 267 (cond ((null DynTraceFlg) 268 (setq DynTraceFlg t) ; initialize DynTraceFlg 269 (setq TracedFns nil)) ; initialize TracedFns 270 271 (t 272 (terpri) 273 (msg N "Dynamics statistic collection in progress" N) 274 (terpri)))) 275 276 277 278 (defun (statFn off) nil 279 (terpri) 280 (msg N "Stats collection turned off" N) 281 (terpri) 282 (terpri) 283 (stopDynStats)) 284 285 (defun (statFn reset) nil 286 (terpri) 287 (msg N "Clearing stats" N) 288 (terpri) 289 (terpri) 290 (clrDynStats)) 291 292 (defun (statFn print) nil 293 (PrintMeasures (car cmdLine))) 294 295 (defun (cp$ lisp) nil 296 (break)) 297 298 (defun (cp$ debug) nil 299 (let ((d (car cmdLine))) 300 (cond ((eq d 'on) (setq debug t) 301 (msg N "Debug flag Set" N )) 302 ((eq d 'off) (setq debug nil) 303 (msg N "Debug flag Reset" N)) 304 (t (msg N "Bad Debug Mode" N))) 305 (terpri))) 306 307 (defun (cp$ trace) nil 308 (let ((mode (car cmdLine))) 309 (setq cmdLine (cdr cmdLine)) 310 (cond ((eq mode 'on) (Trace (mapcar 'intName cmdLine))) 311 ((eq mode 'off) (Untrace (mapcar 'intName cmdLine))) 312 (t (msg N "Bad Trace Mode" N))))) 313 314 (defun intName (fName) 315 (implode 316 (nreverse 317 (append 318 '(p f _) 319 (nreverse 320 (aexplodec fName)))))) 321 322 323 ; function so see if there's enought room on the line to print 324 ; out some information. If not then start on a new line, too 325 ; bad if the info is longer than one line. 326 327 (defun makeroom (rMargin name) 328 (cond ((greaterp (+ (flatc name 0) (nwritn)) rMargin) (msg N) t) 329 (t nil))) 330 331