projects / unix-history / blame
| Commit | Line | Data |
|---|---|---|
| 42b83950 SB |
1 | ; FP interpreter/compiler |
| 2 | ; Copyright (c) 1982 Scott B. Baden | |
| 3 | ; Berkeley, California | |
| edf71f48 DF |
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 | ; | |
| 95f51977 | 9 | (setq SCCS-utils.l "@(#)utils.l 5.1 (Berkeley) 5/31/85") |
| 42b83950 SB |
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 |