(setq SCCS-fix "@(#)fix.l 1.2 7/9/81")
(eval-when (compile eval)
(or (get 'cmumacs 'version) (load 'cmumacs)))
; 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))
(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))
; macro which should go somewhere else
(*** 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)
(*fexpr editf step type))
; (jkf) it is not clear that you want this to take over on all errors,
; but the cmu people seem to want that.
(dv ER%all fixit) ; LWE 1/17/81 MAYBE THIS WILL FIX THIS code
(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)))
((and (car params) (not (eq (car params) 'edit)))
(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))) (reset)))
(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) (zerop cnt))
(prog (nframe val topframe cnt item)
(setq topframe (car framelist))
(or (eq (typep (car cmd)) 'symbol) (return nil))
(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 (debug-print1 (setq frame topframe) nil))
(bot (debug-print1 (setq frame (car rframelist)) nil))
(p (debug-print1 frame nil))
(pp ($prpr (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>|)))
(debug-print1 (setq frame (or nframe frame)) nil))
(or (debug-iter (debug-dnframe frame)) frame))
(debug-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))
(debug-print1 frame nil))
(or (debug-iter (debug-dnfn frame))
(princ '|<bottom of stack>|))))
(debug-findcall item frame rframelist)))
(and frame (debug-print1 frame nil)))
(debug-findcall item frame framelist)))
(and frame (debug-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)))))
(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 ((zerop 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 (debug-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))))
(debug-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))
(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))))))))
(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)))))
(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))
(cond ((zerop diff) (princ '|you are at top of stack.|))
((zerop 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))
nil) ; lets assume nothing is a system function.
(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))