xref: /original-bsd/old/lisp/fp/fp.vax/utils.l (revision 92d3de31) 
1 (setq SCCS-utils.l "@(#)utils.l	1.1	04/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 
326