4.3BSD/usr/lib/lisp/step.l
(setq rcs-step-
"$Header: /usr/lib/lisp/step.l,v 1.1 83/01/29 18:39:46 jkf Exp $")
; vi: set lisp :
;;; LISP Stepping Package
;;;
;;; Adapted by Mitch Marcus for Franz Lisp from Chuck Rich's MACLISP
;;; package.
;;;
;;;
;;; Adapted 2/80 from the Maclisp version of 11/03/76
;;; Further modified 5/80 by Don Cohen (DNC)
;;;
;;; modified by jkf 6/81 to handle funcallhook.
;;;
;;; User Interface Function
;;;
;;; Valid Forms:
;;; (step) or (step nil) :: turn off stepping
;;; (step t) :: turn on stepping right away.
;;; (step e) :: turn on stepping of eval only
;;; (step foo1 foo2 ...) :: turn on stepping when one of fooi is
;;; :: called
;;;
;------ implementation:
; evalhook* is nil meaning no stepping, or t meaning always step
; or is a list of forms which will start continuous stepping.
;
; The hook functions are evalhook* and funcallhook*.
;
(declare (special
evalhook-switch piport
hookautolfcount funcallhook
evalhook evalhook* |evalhook#| prinlevel prinlength
fcn-evalhook fcn-funcallhook
Standard-Input)
(macros nil))
;; First Some Macros
(defun 7bit macro (s)
;; (7BIT n c) tests if n is ascii for c
(list '= (list 'boole 1 127. (cadr s)) (caddr s)))
;--- print*
; indent based on current evalhook recursion level then print the
; arg in form
;
(defun print* macro (s)
;; print with indentation
'(do ((i 1 (1+ i))
(indent (* 2 |evalhook#|))
(prinlevel 3)
(prinlength 5))
((> i indent)
(cond ((eq type 'funcall) (patom "f:")))
(print form))
(tyo 32.)))
(defun step fexpr (arg)
(cond ((or (null arg) (car arg))
(setq evalhook-switch t) ; for fixit package
(setq |evalhook#| 0.) ;initialize depth count
(setq hookautolfcount 0) ; count if auto lfs at break
(setq evalhook nil) ;for safety
(setq funcallhook nil)
; (step e) means just step eval things, else step eval and funcal
(cond ((eq (car arg) 'e)
(setq fcn-evalhook 'evalhook* fcn-funcallhook nil))
(t (setq fcn-evalhook 'evalhook* fcn-funcallhook 'funcallhook*)))
(setq evalhook*
(cond ((null arg) nil)
((or (eq (car arg) t) (eq (car arg) 'e)))
(arg)))
(setq evalhook fcn-evalhook) ;turn system hook to my function
(setq funcallhook fcn-funcallhook)
(sstatus translink nil)
(*rset t) ;must be on for hook to work
(sstatus evalhook t)) ;arm it
(t (setq evalhook* nil)
(setq evalhook nil)
(setq hookautolfcount 0) ; count if auto lfs at break
(setq evalhook-switch nil)
(sstatus evalhook nil))))
;---- funcall-evalhook*
;
; common function to handle evalhook's and funcallhook's.
; the form to be evaluated is given as form and the type (eval or funcall)
; is given as type.
;
(defun funcall-evalhook* (form type)
(cond (evalhook*
;; see if selective feature kicks in here
(and (not (atom form))
(not (eq evalhook* t))
(memq (car form) evalhook*)
(setq evalhook* t)) ; yes, begin stepping always
(cond ((eq evalhook* t)
;; print out form before evaluation
(print*)
(cond ((atom form)
;; since form is atom, we just eval it and print
;; out its value, no need to ask user what to do
(cond ((not (or (numberp form)(null form)(eq form t)))
(princ '" = ")
((lambda (prinlevel prinlength)
(setq form (evalhook form nil nil))
(print form))
3 5)))
(terpri))
(t ; s-expression
(prog (cmd ehookfn fhookfcn)
cmdlp (cond ((greaterp hookautolfcount 0)
(setq hookautolfcount (sub1 hookautolfcount))
(terpr)
(setq cmd #\lf))
(t (setq cmd (let ((piport
Standard-Input))
(drain piport)
(tyi piport)))))
;; uppercase alphabetics
;; dispatch on command character
(cond ((eq cmd #\lf)
; \n so continue
(setq ehookfn fcn-evalhook
fhookfcn fcn-funcallhook))
((memq cmd '(#/p #/P))
; "P" print in full
(print form)
(go cmdlp))
; "G"
((memq cmd '(#/g #/G))
(setq evalhook* nil ;stop everything
ehookfn nil
fhookfcn nil))
((memq cmd '(#/c #/C))
;"C" no deeper
(setq ehookfn nil
fhookfcn nil))
((memq cmd '(#/d #/D))
;"D" call debug
(setq evalhook-switch nil)
(sstatus evalhook nil)
(debug)
(setq evalhook-switch t)
(sstatus evalhook t)
(go cmdlp))
((memq cmd '(#/b #/B))
; "B" give breakpoint
(break step)
(print*)
(go cmdlp))
((memq cmd '(#/q #/Q))
; "Q" stop stepping
(step nil)
(reset))
((memq cmd '(#/n #/N))
(setq hookautolfcount
(let ((piport Standard-Input))
(read)))
(cond ((not (numberp hookautolfcount))
(patom "arg to n should be number")
(terpr)
(setq hookautolfcount 0))))
; "s" eval form
((memq cmd '(#/s #/S))
(let ((piport Standard-Input)
(fcns nil))
(setq fcns (read))
(cond ((dtpr fcns)
(setq evalhook* fcns))
((symbolp fcns)
(setq evalhook* (list fcns))))))
; "e" step eval only
((memq cmd '(#/e #/E))
(setq fcn-funcallhook nil))
; "?", "H" show the options
((memq cmd '(72 104 63.))
#+cmu (ty /usr/lisp/doc/step\.ref)
#-cmu(stephelpform)
(terpri)
(go cmdlp))
((eq cmd #\eof)
(patom "EOF typed")
(terpr))
(t (princ '"Try one of ?BCDGMPQ or <cr>")
(go cmdlp)))
;; evaluate form
(clear-input-buffer)
((lambda (|evalhook#|)
(setq form (continue-evaluation
form
type
ehookfn
fhookfcn)))
(1+ |evalhook#|))
;; print out evaluated form
(cond ((and evalhook*
(or (eq type 'funcall)
(not (zerop |evalhook#|))))
(let ((type nil))
(print*))
(terpri)
)))))
;;return evaluated form
form)
(t ; why was this here? (clear-input-buffer)
(continue-evaluation form type fcn-evalhook fcn-funcallhook))))
(t ; why was this here? (clear-input-buffer)
(continue-evaluation form type fcn-evalhook fcn-funcallhook))))
;--- stephelpform
;
; print a summary of the functions of step
;
(defun stephelpform nil
(patom "<cr> - single step; n <number> - step <number> times")(terpr)
(patom "b - break; q - quit stepping; d - call debug;") (terpri)
(patom "c - turn off step for deeper levels; e - stop at eval forms only")
(terpri)
(patom "h,? - print this") (terpr))
;--- funcallhook*
;
; automatically called when a funcall is done and funcallhook*'s
; value is the name of this function (funcallhook*). When this is
; called, a function with n-1 args is being funcalled, the args
; to the function are (arg 1) through (arg (sub1 n)), the name of
; the function is (arg n)
;
(defun funcallhook* n
(let ((name (arg n))
(args (listify (sub1 n))))
(funcall-evalhook* (cons name args) 'funcall)))
;--- evalhook*
;
; called whenever an eval is done and evalhook*'s value is the
; name of this function (evalhook*). arg is the thing being
; evaluated.
;
(defun evalhook* (arg)
(funcall-evalhook* arg 'eval))
(defun continue-evaluation (form type evalhookfcn funcallhookfcn)
(cond ((eq type 'eval) (evalhook form evalhookfcn funcallhookfcn))
(t (funcallhook form funcallhookfcn evalhookfcn))))
(or (boundp 'prinlength) (setq prinlength nil))
(or (boundp 'prinlevel) (setq prinlevel nil))
; Standard-Input is a variable bound to the initial stdin port. It is
; bound in the auxfns0 package, but older lisps may not have that new
; package, so in case they don't we approximate Standard-Input with nil
; which works in many cases, but drain's do not work.
(or (boundp 'Standard-Input) (setq Standard-Input nil))
(defun clear-input-buffer nil (drain Standard-Input))