Commit | Line | Data |
---|---|---|
8f6f3710 C |
1 | (setq rcs-step- |
2 | "$Header: /usr/lib/lisp/step.l,v 1.1 83/01/29 18:39:46 jkf Exp $") | |
3 | ||
4 | ; vi: set lisp : | |
5 | ||
6 | ;;; LISP Stepping Package | |
7 | ;;; | |
8 | ;;; Adapted by Mitch Marcus for Franz Lisp from Chuck Rich's MACLISP | |
9 | ;;; package. | |
10 | ;;; | |
11 | ;;; | |
12 | ;;; Adapted 2/80 from the Maclisp version of 11/03/76 | |
13 | ;;; Further modified 5/80 by Don Cohen (DNC) | |
14 | ;;; | |
15 | ;;; modified by jkf 6/81 to handle funcallhook. | |
16 | ;;; | |
17 | ;;; User Interface Function | |
18 | ;;; | |
19 | ;;; Valid Forms: | |
20 | ;;; (step) or (step nil) :: turn off stepping | |
21 | ;;; (step t) :: turn on stepping right away. | |
22 | ;;; (step e) :: turn on stepping of eval only | |
23 | ;;; (step foo1 foo2 ...) :: turn on stepping when one of fooi is | |
24 | ;;; :: called | |
25 | ;;; | |
26 | ;------ implementation: | |
27 | ; evalhook* is nil meaning no stepping, or t meaning always step | |
28 | ; or is a list of forms which will start continuous stepping. | |
29 | ; | |
30 | ; The hook functions are evalhook* and funcallhook*. | |
31 | ; | |
32 | ||
33 | (declare (special | |
34 | evalhook-switch piport | |
35 | hookautolfcount funcallhook | |
36 | evalhook evalhook* |evalhook#| prinlevel prinlength | |
37 | fcn-evalhook fcn-funcallhook | |
38 | Standard-Input) | |
39 | (macros nil)) | |
40 | ||
41 | ;; First Some Macros | |
42 | ||
43 | (defun 7bit macro (s) | |
44 | ;; (7BIT n c) tests if n is ascii for c | |
45 | (list '= (list 'boole 1 127. (cadr s)) (caddr s))) | |
46 | ||
47 | ;--- print* | |
48 | ; indent based on current evalhook recursion level then print the | |
49 | ; arg in form | |
50 | ; | |
51 | (defun print* macro (s) | |
52 | ;; print with indentation | |
53 | '(do ((i 1 (1+ i)) | |
54 | (indent (* 2 |evalhook#|)) | |
55 | (prinlevel 3) | |
56 | (prinlength 5)) | |
57 | ((> i indent) | |
58 | (cond ((eq type 'funcall) (patom "f:"))) | |
59 | (print form)) | |
60 | (tyo 32.))) | |
61 | ||
62 | (defun step fexpr (arg) | |
63 | (cond ((or (null arg) (car arg)) | |
64 | (setq evalhook-switch t) ; for fixit package | |
65 | (setq |evalhook#| 0.) ;initialize depth count | |
66 | (setq hookautolfcount 0) ; count if auto lfs at break | |
67 | (setq evalhook nil) ;for safety | |
68 | (setq funcallhook nil) | |
69 | ; (step e) means just step eval things, else step eval and funcal | |
70 | (cond ((eq (car arg) 'e) | |
71 | (setq fcn-evalhook 'evalhook* fcn-funcallhook nil)) | |
72 | (t (setq fcn-evalhook 'evalhook* fcn-funcallhook 'funcallhook*))) | |
73 | (setq evalhook* | |
74 | (cond ((null arg) nil) | |
75 | ((or (eq (car arg) t) (eq (car arg) 'e))) | |
76 | (arg))) | |
77 | (setq evalhook fcn-evalhook) ;turn system hook to my function | |
78 | (setq funcallhook fcn-funcallhook) | |
79 | (sstatus translink nil) | |
80 | (*rset t) ;must be on for hook to work | |
81 | (sstatus evalhook t)) ;arm it | |
82 | (t (setq evalhook* nil) | |
83 | (setq evalhook nil) | |
84 | (setq hookautolfcount 0) ; count if auto lfs at break | |
85 | (setq evalhook-switch nil) | |
86 | (sstatus evalhook nil)))) | |
87 | ||
88 | ||
89 | ;---- funcall-evalhook* | |
90 | ; | |
91 | ; common function to handle evalhook's and funcallhook's. | |
92 | ; the form to be evaluated is given as form and the type (eval or funcall) | |
93 | ; is given as type. | |
94 | ; | |
95 | ||
96 | (defun funcall-evalhook* (form type) | |
97 | (cond (evalhook* | |
98 | ;; see if selective feature kicks in here | |
99 | (and (not (atom form)) | |
100 | (not (eq evalhook* t)) | |
101 | (memq (car form) evalhook*) | |
102 | (setq evalhook* t)) ; yes, begin stepping always | |
103 | ||
104 | (cond ((eq evalhook* t) | |
105 | ;; print out form before evaluation | |
106 | (print*) | |
107 | ||
108 | (cond ((atom form) | |
109 | ;; since form is atom, we just eval it and print | |
110 | ;; out its value, no need to ask user what to do | |
111 | (cond ((not (or (numberp form)(null form)(eq form t))) | |
112 | (princ '" = ") | |
113 | ((lambda (prinlevel prinlength) | |
114 | (setq form (evalhook form nil nil)) | |
115 | (print form)) | |
116 | 3 5))) | |
117 | (terpri)) | |
118 | (t ; s-expression | |
119 | (prog (cmd ehookfn fhookfcn) | |
120 | ||
121 | cmdlp (cond ((greaterp hookautolfcount 0) | |
122 | (setq hookautolfcount (sub1 hookautolfcount)) | |
123 | (terpr) | |
124 | (setq cmd #\lf)) | |
125 | (t (setq cmd (let ((piport | |
126 | Standard-Input)) | |
127 | (drain piport) | |
128 | (tyi piport))))) | |
129 | ||
130 | ;; uppercase alphabetics | |
131 | ;; dispatch on command character | |
132 | (cond ((eq cmd #\lf) | |
133 | ; \n so continue | |
134 | (setq ehookfn fcn-evalhook | |
135 | fhookfcn fcn-funcallhook)) | |
136 | ||
137 | ((memq cmd '(#/p #/P)) | |
138 | ; "P" print in full | |
139 | (print form) | |
140 | (go cmdlp)) | |
141 | ||
142 | ; "G" | |
143 | ((memq cmd '(#/g #/G)) | |
144 | (setq evalhook* nil ;stop everything | |
145 | ehookfn nil | |
146 | fhookfcn nil)) | |
147 | ||
148 | ((memq cmd '(#/c #/C)) | |
149 | ;"C" no deeper | |
150 | (setq ehookfn nil | |
151 | fhookfcn nil)) | |
152 | ||
153 | ((memq cmd '(#/d #/D)) | |
154 | ;"D" call debug | |
155 | (setq evalhook-switch nil) | |
156 | (sstatus evalhook nil) | |
157 | (debug) | |
158 | (setq evalhook-switch t) | |
159 | (sstatus evalhook t) | |
160 | (go cmdlp)) | |
161 | ||
162 | ||
163 | ((memq cmd '(#/b #/B)) | |
164 | ; "B" give breakpoint | |
165 | (break step) | |
166 | (print*) | |
167 | (go cmdlp)) | |
168 | ||
169 | ((memq cmd '(#/q #/Q)) | |
170 | ; "Q" stop stepping | |
171 | (step nil) | |
172 | (reset)) | |
173 | ||
174 | ((memq cmd '(#/n #/N)) | |
175 | (setq hookautolfcount | |
176 | (let ((piport Standard-Input)) | |
177 | (read))) | |
178 | (cond ((not (numberp hookautolfcount)) | |
179 | (patom "arg to n should be number") | |
180 | (terpr) | |
181 | (setq hookautolfcount 0)))) | |
182 | ||
183 | ; "s" eval form | |
184 | ((memq cmd '(#/s #/S)) | |
185 | (let ((piport Standard-Input) | |
186 | (fcns nil)) | |
187 | (setq fcns (read)) | |
188 | (cond ((dtpr fcns) | |
189 | (setq evalhook* fcns)) | |
190 | ((symbolp fcns) | |
191 | (setq evalhook* (list fcns)))))) | |
192 | ||
193 | ; "e" step eval only | |
194 | ((memq cmd '(#/e #/E)) | |
195 | (setq fcn-funcallhook nil)) | |
196 | ||
197 | ; "?", "H" show the options | |
198 | ((memq cmd '(72 104 63.)) | |
199 | #+cmu (ty /usr/lisp/doc/step\.ref) | |
200 | #-cmu(stephelpform) | |
201 | (terpri) | |
202 | (go cmdlp)) | |
203 | ((eq cmd #\eof) | |
204 | (patom "EOF typed") | |
205 | (terpr)) | |
206 | ||
207 | (t (princ '"Try one of ?BCDGMPQ or <cr>") | |
208 | (go cmdlp))) | |
209 | ||
210 | ;; evaluate form | |
211 | (clear-input-buffer) | |
212 | ((lambda (|evalhook#|) | |
213 | (setq form (continue-evaluation | |
214 | form | |
215 | type | |
216 | ehookfn | |
217 | fhookfcn))) | |
218 | (1+ |evalhook#|)) | |
219 | ||
220 | ;; print out evaluated form | |
221 | (cond ((and evalhook* | |
222 | (or (eq type 'funcall) | |
223 | (not (zerop |evalhook#|)))) | |
224 | (let ((type nil)) | |
225 | (print*)) | |
226 | (terpri) | |
227 | ))))) | |
228 | ;;return evaluated form | |
229 | form) | |
230 | (t ; why was this here? (clear-input-buffer) | |
231 | (continue-evaluation form type fcn-evalhook fcn-funcallhook)))) | |
232 | (t ; why was this here? (clear-input-buffer) | |
233 | (continue-evaluation form type fcn-evalhook fcn-funcallhook)))) | |
234 | ||
235 | ;--- stephelpform | |
236 | ; | |
237 | ; print a summary of the functions of step | |
238 | ; | |
239 | (defun stephelpform nil | |
240 | (patom "<cr> - single step; n <number> - step <number> times")(terpr) | |
241 | (patom "b - break; q - quit stepping; d - call debug;") (terpri) | |
242 | (patom "c - turn off step for deeper levels; e - stop at eval forms only") | |
243 | (terpri) | |
244 | (patom "h,? - print this") (terpr)) | |
245 | ||
246 | ;--- funcallhook* | |
247 | ; | |
248 | ; automatically called when a funcall is done and funcallhook*'s | |
249 | ; value is the name of this function (funcallhook*). When this is | |
250 | ; called, a function with n-1 args is being funcalled, the args | |
251 | ; to the function are (arg 1) through (arg (sub1 n)), the name of | |
252 | ; the function is (arg n) | |
253 | ; | |
254 | (defun funcallhook* n | |
255 | (let ((name (arg n)) | |
256 | (args (listify (sub1 n)))) | |
257 | (funcall-evalhook* (cons name args) 'funcall))) | |
258 | ||
259 | ;--- evalhook* | |
260 | ; | |
261 | ; called whenever an eval is done and evalhook*'s value is the | |
262 | ; name of this function (evalhook*). arg is the thing being | |
263 | ; evaluated. | |
264 | ; | |
265 | (defun evalhook* (arg) | |
266 | (funcall-evalhook* arg 'eval)) | |
267 | ||
268 | (defun continue-evaluation (form type evalhookfcn funcallhookfcn) | |
269 | (cond ((eq type 'eval) (evalhook form evalhookfcn funcallhookfcn)) | |
270 | (t (funcallhook form funcallhookfcn evalhookfcn)))) | |
271 | ||
272 | ||
273 | (or (boundp 'prinlength) (setq prinlength nil)) | |
274 | ||
275 | (or (boundp 'prinlevel) (setq prinlevel nil)) | |
276 | ||
277 | ; Standard-Input is a variable bound to the initial stdin port. It is | |
278 | ; bound in the auxfns0 package, but older lisps may not have that new | |
279 | ; package, so in case they don't we approximate Standard-Input with nil | |
280 | ; which works in many cases, but drain's do not work. | |
281 | (or (boundp 'Standard-Input) (setq Standard-Input nil)) | |
282 | (defun clear-input-buffer nil (drain Standard-Input)) |