BSD 4 release

[unix-history] / usr / lib / lisp / fix.l

(setq SCCS-fix "@(#)fix.l       1.1     10/2/80")

(dv fixfns
   ((*** 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)
             (*fexpr editf step type))
    (sstatus feature fixit)
    (*rset t)
    ER%tpl
    fixit
    debug
    debug-iter
    debug1
    debug-bktrace
    debug-print
    debug-print1
    debug-findcall
    debug-scanflist
    debug-scanstk
    debug-getframes
    debug-nextframe
    debug-upframe
    debug-dnframe
    debug-upfn
    debug-dnfn
    debug-showvar
    debug-nedit
    debug-insidep
    debug-findusrfn
    debug-findexpr
    debug-pop
    debug-where
    debug-sysp
    interrupt-handlers
    handler-labels
    (or (boundp 'traced-stuff) (setq traced-stuff nil))
    (or (boundp 'evalhook-switch) (setq evalhook-switch nil))
    (setq hush-debug 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)
        (*fexpr editf step type))

(sstatus feature fixit)

(*rset t)

(dv ER%tpl fixit)

(def fixit
 (nlambda (l)
   (prog (piport)
         (while t (eval (cons 'debug l))))))

(def debug
 (nlambda (params)
   (prog (cmd frame framelist rframelist nframe val infile)
         (setq infile t)
         (and evalhook-switch (step nil))
         (setq rframelist
               (reverse
                (setq framelist
                      (or (debug-getframes)
                          (list
                           (debug-scanstk '(nil) '(debug)))))))
         (setq frame (debug-findexpr (car framelist)))
         (tab 0)
         (cond
          ((and (car params) (not (eq (car params) 'edit)))
           (terpri)
           (princ '|;debug |)
           (princ params)
           (terpri)
           (go loop)))
         (debug-print1 frame nil)
         (terpri)
         (cond (hush-debug (setq hush-debug nil) (go loop))
               ((not (memq 'edit params)) (go loop)))
         (drain nil)
         (princ '|type e to edit, <cr> to debug: |)
         (setq val (tyi))
         (cond ((or (= val 69) (= val 101))
                (and (errset (debug-nedit frame))
                     (setq cmd '(ok))
                     (go cmdr)))
               ((or (= val 78) (= val 110)) (terpri) (debug-pop)))
    loop (terpri)
         (princ ':)
         (cond ((null (setq cmd (lineread))) (reset)))
    cmdr (cond
          ((dtpr (car cmd))
           (setq val (eval (car cmd) (cadddr frame)))
           ($prin1 val)
           (terpri)
           (go loop)))
         (setq nframe (debug1 cmd frame))
         (and (not (atom nframe)) (setq frame nframe) (go loop))
         ($prin1 (or nframe (car cmd)))
         (princ '" Huh? - type h for help")
         (go loop))))

(def debug-iter
 (macro (x)
   (cons 'prog
         (cons 'nil
               (cons 'loop
                     (cons (list 'setq 'nframe (cadr x))
                           '((setq cnt (|1-| cnt))
                             (and (or (null nframe) (zerop cnt))
                                  (return nframe))
                             (setq frame nframe)
                             (go loop))))))))

(def debug1
 (lambda (cmd frame)
   (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)))
         (setq cnt
               (cond ((fixp (cadr cmd)) (cadr cmd))
                     ((fixp (caddr cmd)) (caddr cmd))
                     (t 1)))
         (and (< cnt 1) (setq cnt 1))
         (setq item
               (cond ((symbolp (cadr cmd)) (cadr cmd))
                     ((symbolp (caddr cmd)) (caddr cmd))))
         (and item
              (cond ((memq (car cmd) '(u up))
                     (setq cmd (cons 'ups (cdr cmd))))
                    ((memq (car cmd) '(d dn))
                     (setq cmd (cons 'dns (cdr cmd))))))
         (selectq (car 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))
                  (help
                   (cond ((cdr cmd) (eval cmd))
                         (t (ty |/usr/lisp/doc/fixit.ref|))))
                  ((? h) (ty |/usr/lisp/doc/fixit.ref|))
                  ((go ok)
                   (setq frame (debug-findexpr topframe))
                   (cond ((eq (caaddr frame) 'debug)
                          (freturn (cadr frame) t))
                         (t (fretry (cadr frame) frame))))
                  (pop (debug-pop))
                  (step (setq frame (debug-findexpr frame))
                        (step t)
                        (fretry (cadr (debug-dnframe frame)) frame))
                  (redo (and item
                             (setq 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))
                  (editf
                   (cond ((null item)
                          (setq frame
                                (or (debug-findusrfn (debug-nedit frame))
                                    (car rframelist))))
                         ((dtpr (getd item))
                          (errset (funcall 'editf (list item))))
                         (t (setq frame nil))))
                  (u (debug-iter (debug-upframe frame))
                     (cond
                      ((null nframe) (terpri) (princ '|<top of stack>|)))
                     (debug-print1 (setq frame (or nframe frame)) nil))
                  (d (setq nframe
                           (or (debug-iter (debug-dnframe frame)) frame))
                     (debug-print1 nframe nil)
                     (cond ((eq frame nframe)
                            (terpri)
                            (princ '|<bottom of stack>|))
                           (t (setq frame nframe))))
                  (up (setq nframe (debug-iter (debug-upfn frame)))
                      (cond
                       ((null nframe) (terpri) (princ '|top of stack|)))
                      (setq frame (or nframe topframe))
                      (debug-print1 frame nil))
                  (dn (setq frame
                            (or (debug-iter (debug-dnfn frame))
                                (car rframelist)))
                      (debug-print1 frame nil)
                      (cond
                       ((not (eq frame nframe))
                        (terpri)
                        (princ '|<bottom of stack>|))))
                  (ups (setq frame
                             (debug-iter
                              (debug-findcall item frame rframelist)))
                       (and frame (debug-print1 frame nil)))
                  (dns (setq frame
                             (debug-iter
                              (debug-findcall item frame framelist)))
                       (and frame (debug-print1 frame nil)))
                  (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-bktrace
 (lambda (cmd oframe)
   (prog (sel cnt item frame nframe)
         (mapc '(lambda (x)
                        (setq sel
                              (cons (selectq x
                                             (f 'fns)
                                             (a 'sysp)
                                             (v 'bind)
                                             (e 'expr)
                                             (c 'current)
                                             'bogus)
                                    sel)))
               (cddr (explodec (car cmd))))
         (setq item
               (cond ((eq (typep (cadr cmd)) 'symbol) (cadr cmd))
                     ((eq (typep (caddr cmd)) 'symbol) (caddr cmd))))
         (cond ((debug-sysp item) (setq sel (cons 'sysp sel)))
               ((not (memq 'sysp sel))
                (setq sel (cons 'user sel))))
         (setq cnt
               (cond ((fixp (cadr cmd)) (cadr cmd))
                     ((fixp (caddr cmd)) (caddr cmd))
                     (item 1)))
         (cond ((null cnt)
                (setq frame
                      (cond ((memq 'current sel) oframe)
                            (t (car rframelist))))
                (go dbpr))
               ((null item)
                (setq frame (car framelist))
                (and (or (not (memq 'user sel))
                         (atom (caddr (car framelist)))
                         (not (debug-sysp (caaddr (car framelist)))))
                     (setq cnt (|1-| cnt)))
                (setq frame
                      (cond ((zerop cnt) frame)
                            ((memq 'user sel)
                             (debug-iter (debug-dnfn frame)))
                            (t (debug-iter (debug-dnframe frame)))))
                (setq frame (or frame (car rframelist)))
                (go dbpr))
               (t (setq frame (car framelist))))
         (setq frame
               (cond ((and (= cnt 1)
                           (not (atom (caddr (car framelist))))
                           (eq item (caaddr (car framelist))))
                      (car framelist))
                     ((debug-iter (debug-findcall item frame framelist)))
                     (t (car rframelist))))
    dbpr (debug-print frame sel oframe)
         (cond ((eq frame (car rframelist))
                (terpri)
                (princ '|<bottom of stack>|)
                (terpri))
               (t (terpri)))
         (cond
          ((memq 'bogus sel)
           (terpri)
           (princ (car cmd))
           (princ '| contains an invalid bk modifier|)))
         (return oframe))))

(def debug-print
 (lambda (frame sel ptr)
   (prog (curframe)
         (setq curframe (car framelist))
    loop (cond ((not
                 (and (memq 'user sel)
                      (not (atom (caddr curframe)))
                      (debug-sysp (caaddr curframe))))
                (debug-print1 curframe sel)
                (and (eq curframe ptr) (princ '|   <--- you are here|)))
               ((eq curframe ptr)
                (terpri)
                (princ '|  <--- you are somewhere in here|)))
         (and (eq curframe frame) (return frame))
         (setq curframe (debug-dnframe curframe))
         (or curframe (return frame))
         (go loop))))

(def debug-print1
 (lambda (frame sel)
   (prog (prinlevel prinlength varlist)
         (and (not (memq 'expr sel))
              (setq prinlevel 2)
              (setq prinlength 5))
         (cond
          ((atom (caddr frame))
           (terpri)
           (princ '|   |)
           ($prin1 (caddr frame))
           (princ '| <- eval error|)
           (return t)))
         (and (memq 'bind sel)
              (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))))))
              (mapc (function
                     (lambda (v)
                             (debug-showvar v
                                            (or (debug-upframe frame)
                                                frame))))
                    (cond ((and varlist (atom varlist)) (ncons varlist))
                          (t varlist))))
         (and (memq 'user sel)
              (debug-sysp (caaddr frame))
              (return nil))
         (cond ((memq (caaddr frame) interrupt-handlers)
                (terpri)
                (princ '<------------)
                ($prin1 (cadr (assq (caaddr frame) handler-labels)))
                (princ '-->))
               ((eq (caaddr frame) 'debug)
                (terpri)
                (princ '<------debug------>))
               ((memq 'fns sel)
                (terpri)
                (and (debug-sysp (caaddr frame)) (princ '|  |))
                ($prin1 (caaddr frame)))
               (t (terpri)
                  ($prin1
                   (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>|))
         (return t))))

(def debug-findcall
 (lambda (fn frame flist)
   (prog nil
    loop (setq frame (debug-nextframe frame flist nil))
         (or frame (return nil))
         (cond ((atom (caddr frame))
                (cond ((eq (caddr frame) fn) (return frame)) (t (go loop))))
               ((eq (caaddr frame) fn) (return frame))
               (t (go loop))))))

(def debug-scanflist
 (lambda (frame fnset)
   (prog nil
    loop (or frame (return nil))
         (and (not (atom (caddr frame)))
              (memq (caaddr frame) fnset)
              (return frame))
         (setq frame (debug-dnframe frame))
         (go loop))))

(def debug-scanstk
 (lambda (frame fnset)
   (prog nil
    loop (or frame (return nil))
         (and (not (atom (caddr frame)))
              (memq (caaddr frame) fnset)
              (return frame))
         (setq frame (evalframe (cadr frame)))
         (go loop))))

(def debug-getframes
 (lambda nil
   (prog (flist fnew)
         (setq fnew
               (debug-scanstk '(nil)
                              (cons 'debug interrupt-handlers)))
    loop (and (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))))
         (and (null flist)
              (eq (car fnew) 'apply)
              (memq (caaddr fnew) interrupt-handlers)
              (setq fnew (evalframe (cadr fnew))))
         (and (eq (car fnew) 'apply)
              (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)))
              (go loop))
         (and (not (atom (caddr fnew)))
              (memq (caaddr fnew) '(evalhook* evalhook))
              (setq fnew (evalframe (cadr fnew)))
              (go loop))
         (and (eq (car fnew) 'apply)
              (eq (caaddr fnew) 'eval)
              (cadadr (caddr fnew))
              (or (not (fixp (cadadr (caddr fnew))))
                  (= (cadadr (caddr fnew)) -1))
              (setq fnew (evalframe (cadr fnew)))
              (go loop))
         (and fnew
              (setq flist (cons fnew flist))
              (setq fnew (evalframe (cadr fnew)))
              (go loop))
         (return (nreverse flist)))))

(def debug-nextframe
 (lambda (frame flist sel)
   (prog nil
         (setq flist (cdr (memq frame flist)))
         (and (not (memq 'user sel)) (return (car flist)))
    loop (or flist (return nil))
         (cond
          ((or (atom (caddr (car flist)))
               (not (debug-sysp (caaddr (car flist)))))
           (return (car flist))))
         (setq flist (cdr flist))
         (go loop))))

(def debug-upframe
 (lambda (frame)
   (debug-nextframe frame rframelist nil)))

(def debug-dnframe
 (lambda (frame)
   (debug-nextframe frame framelist nil)))

(def debug-upfn
 (lambda (frame)
   (debug-nextframe frame rframelist '(user))))

(def debug-dnfn
 (lambda (frame)
   (debug-nextframe frame framelist '(user))))

(def debug-showvar
 (lambda (var frame)
   (terpri)
   (princ '|   |)
   (princ var)
   (princ '| = |)
   ($prin1
    ((lambda (val) (cond ((atom val) '?) (t (car val))))
     (errset (eval var (cadddr frame)) nil)))))

(def debug-nedit
 (lambda (frame)
   (prog (val body elem nframe)
         (setq elem (caddr frame))
         (setq val frame)
    scan (setq val (debug-findusrfn val))
         (or val (go nofn))
         (setq body (getd (caaddr val)))
         (cond ((debug-insidep elem body)
                (princ '=)
                ($prin1 (caaddr val))
                (edite body
                       (list 'f (cons '== elem) 'tty:)
                       (caaddr val))
                (return frame))
               ((or (eq elem (caddr val)) (debug-insidep elem (caddr val)))
                (setq val (debug-dnframe val))
                (go scan)))
    nofn (setq nframe (debug-dnframe frame))
         (or nframe (go doit))
         (and (debug-insidep elem (caddr nframe))
              (setq frame nframe)
              (go nofn))
    doit (edite (caddr frame)
                (and (debug-insidep elem (caddr frame))
                     (list 'f (cons '== elem) 'tty:))
                nil)
         (return frame))))

(def debug-insidep
 (lambda (elem expr)
   (car (errset (edite expr (list 'f (cons '== elem)) nil)))))

(def debug-findusrfn
 (lambda (frame)
   (cond ((null frame) nil)
         ((and (dtpr (caddr frame))
               (symbolp (caaddr frame))
               (dtpr (getd (caaddr frame))))
          frame)
         (t (debug-findusrfn (debug-dnframe frame))))))

(def debug-findexpr
 (lambda (frame)
   (cond ((null frame) nil)
         ((and (eq (car frame) 'eval) (not (atom (caddr frame))))
          frame)
         (t (debug-findexpr (debug-dnframe frame))))))

(def debug-pop
 (lambda nil
   (prog (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)))
         (go l))))

(def debug-where
 (lambda (frame)
   (prog (lev diff nframe)
         (setq lev (- (length framelist) (length (memq frame rframelist))))
         (setq diff (- (length framelist) lev 1))
         (debug-print1 frame nil)
         (terpri)
         (cond ((zerop diff) (princ '|you are at top of stack.|))
               ((zerop lev) (princ '|you are at bottom of stack.|))
               (t (princ '|you are |)
                  (princ diff)
                  (cond ((= diff 1) (princ '| frame from the top.|))
                        (t (princ '| frames from the top.|)))))
         (terpri)
         (and (or (atom (caddr frame)) (not (eq (car frame) 'eval)))
              (return nil))
         (setq lev 0)
         (setq nframe frame)
    lp   (and (setq nframe (debug-findcall (caaddr nframe) nframe framelist))
              (setq lev (|1+| lev))
              (go lp))
         (princ '|there are |)
         (princ lev)
         (princ '| |)
         (princ (caaddr frame))
         (princ '|'s below.|)
         (terpri))))

(def debug-sysp
 (lambda (x)
   (and (sysp x) (symbolp x) (not (dtpr (getd x))))))

(dv interrupt-handlers (fixit))

(dv handler-labels
   ((fixit error)
    (debug-ubv-handler ubv)
    (debug-udf-handler udf)
    (debug-fac-handler fac)
    (debug-ugt-handler ugt)
    (debug-wta-handler wta)
    (debug-wna-handler wna)
    (debug-iol-handler iol)
    (debug-*rset-handler rst)
    (debug-mer-handler mer)
    (debug-gcd-handler gcd)
    (debug-gcl-handler gcl)
    (debug-gco-handler gco)
    (debug-pdl-handler pdl)))

(or (boundp 'traced-stuff) (setq traced-stuff nil))

(or (boundp 'evalhook-switch) (setq evalhook-switch nil))

(setq hush-debug nil)