![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to utils.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / fp|
Return to utils.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / fp |
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-utils.l "@(#)utils.l 5.1 (Berkeley) 5/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:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.