;;;;;;;;;;;;;;;;;;;;;;;;;;;;; fix.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The fixit debugger modified to use "pearlfixprintfn" and to allow
; use of "> fcnname" or "> 'newvalue" in case of an undefined
; function or unbound variable respectively.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Modified for use with PEARL by Joe Faletti 1/6/82
;; (eval-when (compile eval)
;; (or (get 'cmumacs 'version) (load 'cmumacs)))
; Only the necessary functions are included, below
; dv (=defv), ***, lineread, and ty
;--- dv :: set variable to value
; (dv name value) name is setq'ed to value (no evaluation)
(defmacro dv (name value)
;--- *** :: comment macro
(defmacro *** (&rest x) nil)
(defmacro lineread (&optional (x nil))
(def ty (macro (f) (append '(exec cat) (cdr f))))
; LWE 1/11/81 Hack hack....
; LWE 1/11/81 Bet you didn't know this, but this won't work INTERPRETED,
; but Dave assures me it works compiled. (In MACLisp...)
(declare (special cmd frame x cnt var init label part incr limit selectq))
((*** This is FIXIT written by David Touretzky and adapted to Franz by Don
(declare (special framelist rframelist interrupt-handlers handler-labels)
(special prinlevel prinlength evalhook-switch traced-stuff)
(special lastword piport hush-debug)
(*fexpr editf step type))
debug-replace-function-name
(or (boundp 'traced-stuff) (setq traced-stuff nil))
(or (boundp 'evalhook-switch) (setq evalhook-switch nil))
(or (boundp 'traced-stuff) (setq traced-stuff nil))
(or (boundp 'evalhook-switch) (setq evalhook-switch nil))
(or (boundp 'debug-sysmode) (setq debug-sysmode nil))
(*** This is FIXIT written by David Touretzky and adapted to Franz by Don Cohen)
(declare (special framelist rframelist interrupt-handlers handler-labels)
(special prinlevel prinlength evalhook-switch traced-stuff)
(special lastword piport hush-debug debug-sysmode)
(special system-functions\
\a))
(do nil (nil) (eval (cons 'debug l))))))
(prog (cmd frame framelist rframelist nframe val infile)
(and evalhook-switch (step nil))
(debug-scanstk '(nil) '(debug)))))))
(setq frame (debug-findexpr (car framelist)))
; top level ones and calls to err and break.
((and (car params) (not (eq (car params) 'edit)))
(princ (cddddr params))))
(Pdebug-print1 frame nil)
(cond (hush-debug (setq hush-debug nil) (go loop))
((not (memq 'edit params)) (go loop)))
(princ '|type e to edit, <cr> to debug: |)
(cond ((or (\=& val 69) (\=& val 101))
(and (errset (debug-nedit frame))
((or (\=& val 78) (\=& val 110)) (terpri) (debug-pop)))
(cond ((null (setq cmd (lineread)))
(setq val (eval (car cmd) (cadddr frame)))
(setq nframe (debug1 cmd frame))
(and (not (atom nframe)) (setq frame nframe) (go loop))
(print (or nframe (car cmd)))
(princ '" Huh? - type h for help")
(cons (list 'setq 'nframe (cadr x))
(and (or (null nframe) (\=& 0 cnt))
(prog (nframe val topframe cnt item)
(setq topframe (car framelist))
(or (eq (typep (car cmd)) 'symbol) (return nil))
; if "> name", replace function name with new atom
(return (debug-replace-function-name cmd topframe)))
(and (eq (getchar (car cmd) 1) 'b)
(eq (getchar (car cmd) 2) 'k)
(return (debug-bktrace cmd frame)))
(cond ((fixp (cadr cmd)) (cadr cmd))
((fixp (caddr cmd)) (caddr cmd))
(and (<& cnt 1) (setq cnt 1))
(cond ((symbolp (cadr cmd)) (cadr cmd))
((symbolp (caddr cmd)) (caddr cmd))))
(cond ((memq (car cmd) '(u up))
(setq cmd (cons 'ups (cdr cmd))))
((memq (car cmd) '(d dn))
(setq cmd (cons 'dns (cdr cmd))))))
(top (Pdebug-print1 (setq frame topframe) nil))
(bot (Pdebug-print1 (setq frame (car rframelist)) nil))
(p (Pdebug-print1 frame nil))
(pp (valprint (caddr frame)))
(where (debug-where frame))
(cond ((cdr cmd) (eval cmd))
(t (ty |/usr/lisp/doc/fixit.ref|))))
((\? h) (ty |/usr/lisp/doc/fixit.ref|))
(setq frame (debug-findexpr topframe))
(cond ((eq (caaddr frame) 'debug)
(freturn (cadr frame) t))
(t (fretry (cadr frame) frame))))
(step (setq frame (debug-findexpr frame))
(fretry (cadr (debug-dnframe frame)) frame))
(debug-findcall item frame framelist)))
(and frame (fretry (cadr frame) frame)))
(return (setq val (eval (cadr cmd)))
(freturn (cadr frame) val))
(edit (debug-nedit frame))
(or (debug-findusrfn (debug-nedit frame))
(errset (funcall 'editf (list item))))
(u (debug-iter (debug-upframe frame))
((null nframe) (terpri) (princ '|<top of stack>|)))
(Pdebug-print1 (setq frame (or nframe frame)) nil))
(or (debug-iter (debug-dnframe frame)) frame))
(Pdebug-print1 nframe nil)
(princ '|<bottom of stack>|))
(t (setq frame nframe))))
(up (setq nframe (debug-iter (debug-upfn frame)))
((null nframe) (terpri) (princ '|top of stack|)))
(setq frame (or nframe topframe))
(Pdebug-print1 frame nil))
(or (debug-iter (debug-dnfn frame))
(Pdebug-print1 frame nil)
(princ '|<bottom of stack>|))))
(debug-findcall item frame rframelist)))
(and frame (Pdebug-print1 frame nil)))
(debug-findcall item frame framelist)))
(and frame (Pdebug-print1 frame nil)))
(sys (setq debug-sysmode (not debug-sysmode))
(patom "sysmode now ")(patom debug-sysmode) (terpr))
(cond ((not (dtpr (car cmd)))
(*** should there also be a boundp test here)
(debug-showvar (car cmd) frame))
(t (setq frame (car cmd))))))
(return (or frame item)))))
(def debug-replace-function-name
(lambda (cmd frame) (prog (oldname newname errorcall nframe)
(setq errorcall (caddr frame))
(cond ((eq (caddddr errorcall) '|eval: Undefined function |)
(setq oldname (cadddddr errorcall))
(setq newname (cadr cmd))
(setq frame (debug-iter (debug-dnframe frame)))
(dsubst newname oldname frame)
(fretry (cadr frame) frame))
((eq (caddddr errorcall) '|Unbound Variable:|)
(setq oldname (cadddddr errorcall))
(setq newname (eval (cadr cmd)))
(setq frame (debug-iter (debug-dnframe frame)))
(dsubst newname oldname frame)
(fretry (cadr frame) frame))
(prog (sel cnt item frame nframe)
(cddr (explodec (car cmd))))
(cond ((eq (typep (cadr cmd)) 'symbol) (cadr cmd))
((eq (typep (caddr cmd)) 'symbol) (caddr cmd))))
(cond ((debug-sysp item) (setq sel (cons 'sysp sel)))
(setq sel (cons 'user sel))))
(cond ((fixp (cadr cmd)) (cadr cmd))
((fixp (caddr cmd)) (caddr cmd))
(cond ((memq 'current sel) oframe)
(setq frame (car framelist))
(and (or (not (memq 'user sel))
(atom (caddr (car framelist)))
(not (debug-sysp (caaddr (car framelist)))))
(cond ((\=& 0 cnt) frame)
(debug-iter (debug-dnfn frame)))
(t (debug-iter (debug-dnframe frame)))))
(setq frame (or frame (car rframelist)))
(t (setq frame (car framelist))))
(not (atom (caddr (car framelist))))
(eq item (caaddr (car framelist))))
((debug-iter (debug-findcall item frame framelist)))
dbpr (Pdebug-print frame sel oframe)
(cond ((eq frame (car rframelist))
(princ '|<bottom of stack>|)
(princ '| contains an invalid bk modifier|)))
(setq curframe (car framelist))
(not (atom (caddr curframe)))
(debug-sysp (caaddr curframe))))
(Pdebug-print1 curframe sel)
(and (eq curframe ptr) (princ '| <--- you are here|)))
(princ '| <--- you are somewhere in here|)))
(and (eq curframe frame) (return frame))
(setq curframe (debug-dnframe curframe))
(or curframe (return frame))
(prog (prinlevel prinlength varlist)
(and (not (memq 'expr sel))
(pearlfixprintfn (caddr frame))
; (print (valform (caddr frame)))
(princ '| <- eval error|)
(cond ((memq (caaddr frame) '(prog lambda))
(setq varlist (cadr (caddr frame))))
((and (atom (caaddr frame)) (dtpr (getd (caaddr frame))))
(setq varlist (cadr (getd (caaddr frame))))))
(or (debug-upframe frame)
(cond ((and varlist (atom varlist)) (ncons varlist))
(debug-sysp (caaddr frame))
(cond ((memq (caaddr frame) interrupt-handlers)
(print (cadr (assq (caaddr frame) handler-labels)))
((eq (caaddr frame) 'debug)
(princ '<------debug------>))
(and (debug-sysp (caaddr frame)) (princ '| |))
(cond ((eq (car frame) 'eval) (caddr frame))
(t (cons (caaddr frame) (cadr (caddr frame))))))
; (cond ((eq (car frame) 'eval) (caddr frame))
; (t (cons (caaddr frame) (cadr (caddr frame)))))))
(or (not (symbolp (caaddr frame)))
(eq (caaddr frame) (concat (caaddr frame)))
(princ '| <not interned>|))
loop (setq frame (debug-nextframe frame flist nil))
(cond ((atom (caddr frame))
(cond ((eq (caddr frame) fn) (return frame)) (t (go loop))))
((eq (caaddr frame) fn) (return frame))
loop (or frame (return nil))
(and (not (atom (caddr frame)))
(memq (caaddr frame) fnset)
(setq frame (debug-dnframe frame))
loop (or frame (return nil))
(and (not (atom (caddr frame)))
(memq (caaddr frame) fnset)
(setq frame (evalframe (cadr frame)))
(cons 'debug interrupt-handlers)))
loop (and (not debug-sysmode)
(not (atom (caddr fnew)))
(eq (caaddr fnew) 'debug)
(eq (car (evalframe (cadr fnew))) 'apply)
(memq (caaddr (evalframe (cadr fnew))) interrupt-handlers)
(setq fnew (evalframe (cadr fnew))))
(memq (caaddr fnew) interrupt-handlers)
(setq fnew (evalframe (cadr fnew))))
(eq (typep (caaddr fnew)) 'symbol)
(not (eq (caaddr fnew) (concat (caaddr fnew))))
(setq fnew (evalframe (cadr fnew)))
(setq fnew (evalframe (cadr fnew)))
(setq fnew (evalframe (cadr fnew)))
(setq fnew (evalframe (cadr fnew)))
(not (atom (caddr fnew)))
(memq (caaddr fnew) '(evalhook* evalhook))
(setq fnew (evalframe (cadr fnew)))
(or (not (fixp (cadadr (caddr fnew))))
(\= (cadadr (caddr fnew)) -1))
(setq fnew (evalframe (cadr fnew)))
(setq flist (cons fnew flist))
(setq fnew (evalframe (cadr fnew)))
(return (nreverse flist)))))
(lambda (frame flist sel)
(setq flist (cdr (memq frame flist)))
(and (not (memq 'user sel)) (return (car flist)))
loop (or flist (return nil))
((or (atom (caddr (car flist)))
(not (debug-sysp (caaddr (car flist)))))
(debug-nextframe frame rframelist nil)))
(debug-nextframe frame framelist nil)))
(debug-nextframe frame rframelist '(user))))
(debug-nextframe frame framelist '(user))))
((lambda (val) (cond ((atom val) '\?) (t (car val))))
(errset (eval var (cadddr frame)) nil)))))
; ((lambda (val) (cond ((atom val) '\?) (t (car val))))
; (errset (eval var (cadddr frame)) nil))))))
(prog (val body elem nframe)
(setq elem (caddr frame))
scan (setq val (debug-findusrfn val))
(setq body (getd (caaddr val)))
(cond ((debug-insidep elem body)
(list 'f (cons '\=\= elem) 'tty:)
((or (eq elem (caddr val)) (debug-insidep elem (caddr val)))
(setq val (debug-dnframe val))
nofn (setq nframe (debug-dnframe frame))
(and (debug-insidep elem (caddr nframe))
doit (edite (caddr frame)
(and (debug-insidep elem (caddr frame))
(list 'f (cons '\=\= elem) 'tty:))
(car (errset (edite expr (list 'f (cons '\=\= elem)) nil)))))
((and (dtpr (caddr frame))
(dtpr (getd (caaddr frame))))
(t (debug-findusrfn (debug-dnframe frame))))))
((and (eq (car frame) 'eval) (not (atom (caddr frame))))
(t (debug-findexpr (debug-dnframe frame))))))
(setq frame (car framelist))
l (cond ((null (setq frame (evalframe (cadr frame))))(reset)))
(cond ((and (dtpr (caddr frame))(eq (caaddr frame) 'debug))
(freturn (cadr frame) nil)))
(setq lev (- (length framelist) (length (memq frame rframelist))))
(setq diff (- (length framelist) lev 1))
(Pdebug-print1 frame nil)
(cond ((\=& 0 diff) (princ '|you are at top of stack.|))
((\=& 0 lev) (princ '|you are at bottom of stack.|))
(cond ((\=& diff 1) (princ '| frame from the top.|))
(t (princ '| frames from the top.|)))))
(and (or (atom (caddr frame)) (not (eq (car frame) 'eval)))
lp (and (setq nframe (debug-findcall (caaddr nframe) nframe framelist))
(and (sysp x) (symbolp x) (not (dtpr (getd x))))))
(dv interrupt-handlers (fixit))
(debug-*rset-handler rst)
(debug-pdl-handler pdl)))
(or (boundp 'traced-stuff) (setq traced-stuff nil))
(or (boundp 'evalhook-switch) (setq evalhook-switch nil))
;; other functions grabbed from other cmu files to make this file complete
(do ((temp (oblist) (cdr temp))
((null temp)(setq system-functions\
\a sysfuncs));atom has ^G at end
(setq sysfuncs (cons (car temp) sysfuncs))))))
(defun sysp (x) ; (cond ((memq x system-functions\
\a)t))
(memq x '(funcallhook* funcallhook evalhook evalhook*
(or (boundp 'system-functions\
\a) (build-sysp))
(defun fretry (pdlpnt frame)
(cond ((eq (car frame) 'eval) (eval (caddr frame) (cadddr frame)))
(eval `(apply ',(caaddr frame) ',(cadaddr frame))
loop (setq ans (cons (read chan 'EOF) ans))
(cond ((eq (car ans) 'EOF) (return (reverse (cdr ans)))))
loop2(cond ((eq 10 (tyipeek chan)) (return (reverse ans)))
((memq (tyipeek chan) '(41 93))
(aliasdef 'pearlbreak 'fixit)