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