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