(in-package "CONDITIONS") (import '(with-simple-restart abort continue compute-restarts *debug-level* *debug-restarts* *number-of-debug-restarts* *debug-abort* *debug-continue* *debug-condition* *debug-eval* find-restart invoke-restart invoke-restart-interactively restart-name ignore-errors show-restarts conditionp) "SYSTEM") (in-package "SYSTEM") (defvar *abort-restarts* nil) (defmacro with-clcs-break-level-bindings (&body forms) `(let* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*)) (debug-level *DEBUG-LEVEL*) (*DEBUG-RESTARTS* (COMPUTE-RESTARTS)) (*NUMBER-OF-DEBUG-RESTARTS* (LENGTH *DEBUG-RESTARTS*)) (*DEBUG-ABORT* (FIND-RESTART 'ABORT)) (*DEBUG-CONTINUE* (OR (LET ((C (FIND-RESTART 'CONTINUE))) (IF (OR (NOT *DEBUG-CONTINUE*) (NOT (EQ *DEBUG-CONTINUE* C))) C NIL)) (LET ((C (IF *DEBUG-RESTARTS* (FIRST *DEBUG-RESTARTS*) NIL))) (IF (NOT (EQ C *DEBUG-ABORT*)) C NIL)))) (*DEBUG-CONDITION* (if (conditionp at) at *DEBUG-CONDITION*)) (*abort-restarts* (let ((abort-list nil)) (dolist (restart *DEBUG-RESTARTS*) (when (eq 'abort (restart-name restart)) (push restart abort-list))) (nreverse abort-list)))) ,@forms)) (defun clcs-break-level-invoke-restart (-) (COND ((AND (PLUSP -) (< - (+ *NUMBER-OF-DEBUG-RESTARTS* 1))) (LET ((RESTART (NTH (- - 1) *DEBUG-RESTARTS*))) (INVOKE-RESTART-INTERACTIVELY RESTART))) (T (FORMAT T "~&No such restart.")))) ;; From akcl-1-530, changes marked with ;*** (defun clcs-break-level (at &optional env) (let* ((*break-message* (if (or (stringp at) (conditionp at)) ;*** at *break-message*)) ;*** (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*)) ;*** (*quit-tag* nil) ;*** (*break-level* (if (conditionp at) (cons t *break-level*) *break-level*)) (*ihs-base* (1+ *ihs-top*)) (*ihs-top* (1- (ihs-top))) (*current-ihs* *ihs-top*) (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) (*frs-top* (frs-top)) (*break-env* nil) ;;(be *break-enable*) ;*** ;;(*break-enable* ;*** ;;(progn ;*** ;;(if (stringp at) nil be))) ;*** ;;(*standard-input* *terminal-io*) (*readtable* (or *break-readtable* *readtable*)) (*read-suppress* nil) (+ +) (++ ++) (+++ +++) (- -) (* *) (** **) (*** ***) (/ /) (// //) (/// ///) ) ;;(terpri *error-output*) (with-clcs-break-level-bindings ;*** (if (consp at) (set-back at env) (with-simple-restart (abort "Return to debug level ~D." DEBUG-LEVEL) ;*** (format *debug-io* "~&~A~2%" *break-message*) ;*** (when (> (length *link-array*) 0) (format *debug-io* "Fast links are on: do (use-fast-links nil) for debugging~%")) (set-current) ;*** (setq *no-prompt* nil) (show-restarts))) ;*** (catch-fatal 1) (setq *interrupt-enable* t) (loop (setq +++ ++ ++ + + -) (cond (*no-prompt* (setq *no-prompt* nil)) (t (format *debug-io* "~&~a~a>~{~*>~}" (if (stringp at) "" "dbl:") (if (eq *package* (find-package 'user)) "" (package-name *package*)) *break-level*))) (unless ;*** (with-simple-restart (abort "Return to debug level ~D." DEBUG-LEVEL) ;*** (not (catch 'step-continue (setq - (locally (declare (notinline read)) (dbl-read *debug-io* nil *top-eof*))) (when (eq - *top-eof*) (bye)) (let* ( break-command (values (multiple-value-list (LOCALLY (declare (notinline break-call evalhook)) (if (or (keywordp -) (integerp -)) ;*** (setq - (cons - nil))) (cond ((and (consp -) (keywordp (car -))) (setq break-command t) (break-call (car -) (cdr -))) ((and (consp -) (integerp (car -))) ;*** (setq break-command t) ;*** (clcs-break-level-invoke-restart (car -))) ;*** (t (evalhook - nil nil *break-env*))))))) ;*** (setq /// // // / / values *** ** ** * * (car /)) (fresh-line *debug-io*) (dolist (val /) (locally (declare (notinline prin1)) (prin1 val *debug-io*)) (terpri *debug-io*))) nil))) ;*** (terpri *debug-io*) (break-current)))))) (defun clcs-terminal-interrupt (correctablep) (if correctablep (cerror "Continues execution." "Console interrupt.") (error "Console interrupt -- cannot continue."))) (defun clcs-break-quit (&optional (level 0)) (let ((abort (nth level (reverse *abort-restarts*)))) (when abort (invoke-restart-interactively abort))) (break-current)) (setq conditions::*debugger-function* 'break-level) (setq conditions::*debug-command-prefix* "") (defun break-resume () (and *debug-continue* (invoke-restart *debug-continue*))) (putprop :r 'break-resume 'break-command) (putprop :s 'show-restarts 'break-command) (defun break-help () (format *debug-io* " Break-loop Command Summary ([] indicates optional arg) -------------------------- :bl [j] show local variables and their values, or segment of vs if compiled in j stack frames starting at the current one. :bt [n] BACKTRACE [n steps] :down [i] DOWN i frames (one if no i) :env describe ENVIRONMENT of this stack frame (for interpreted). :fr [n] show frame n :loc [i] return i'th local of this frame if its function is compiled (si::loc i) :r RESUME (return from the current break loop). :up [i] UP i frames (one if no i) Example: print a bactrace of the last 4 frames >>:bt 4 Note: (use-fast-links nil) makes all non system function calls be recorded in the stack. (use-fast-links t) is the default Low level commands: ------------------ :p [i] make current the i'th PREVIOUS frame (in list show by :b) :n [i] make current the i'th NEXT frame (in list show by :b) :go [ihs-index] make current the frame corresponding ihs-index :m print the last break message. :s show restarts. :c show function of the current ihs frame. :q [i] quit to top level :r resume from this break loop. :b full backtrace of all functions and special forms. :bs [name] backward search for frame named 'name' :fs [name] search for frame named 'name' :vs [from] [to] Show value stack between FROM and TO :ihs [from] [to] Show Invocation History Stack :bds ['v1 'v2 ..]Show previous special bindings of v1, v2,.. or all if no v1 ") (values) )