;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (in-package "CONDITIONS") (DEFVAR *DEBUG-LEVEL* 0) (DEFVAR *DEBUG-ABORT* NIL) (DEFVAR *DEBUG-CONTINUE* NIL) (DEFVAR *DEBUG-CONDITION* NIL) (DEFVAR *DEBUG-RESTARTS* NIL) (DEFVAR *NUMBER-OF-DEBUG-RESTARTS* 0) (DEFVAR *DEBUG-EVAL* 'EVAL) (DEFVAR *DEBUG-PRINT* #'(LAMBDA (VALUES) (FORMAT T "~&~{~S~^,~%~}" VALUES))) (DEFMACRO DEBUG-COMMAND (X) `(GET ,X 'DEBUG-COMMAND)) (DEFMACRO DEBUG-COMMAND-ARGUMENT-COUNT (X) `(GET ,X 'DEBUG-COMMAND-ARGUMENT-COUNT)) (DEFMACRO DEFINE-DEBUG-COMMAND (NAME BVL &REST BODY) `(PROGN (SETF (DEBUG-COMMAND ',NAME) #'(LAMBDA ,BVL ,@BODY)) (SETF (DEBUG-COMMAND-ARGUMENT-COUNT ',NAME) ,(LENGTH BVL)) ',NAME)) (DEFUN READ-DEBUG-COMMAND () (FORMAT T "~&Debug ~D> " *DEBUG-LEVEL*) (COND ((CHAR= (PEEK-CHAR T) #\:) (READ-CHAR) ;Eat the ":" so that ":1" reliably reads a number. (WITH-INPUT-FROM-STRING (STREAM (READ-LINE)) (LET ((EOF (LIST NIL))) (DO ((FORM (LET ((*PACKAGE* (FIND-PACKAGE "KEYWORD"))) (READ STREAM NIL EOF)) (READ STREAM NIL EOF)) (L '() (CONS FORM L))) ((EQ FORM EOF) (NREVERSE L)))))) (T (LIST :EVAL (READ))))) (DEFINE-DEBUG-COMMAND :EVAL (FORM) (FUNCALL *DEBUG-PRINT* (MULTIPLE-VALUE-LIST (FUNCALL *DEBUG-EVAL* FORM)))) (DEFINE-DEBUG-COMMAND :ABORT () (IF *DEBUG-ABORT* (INVOKE-RESTART-INTERACTIVELY *DEBUG-ABORT*) (FORMAT T "~&There is no way to abort.~%"))) (DEFINE-DEBUG-COMMAND :CONTINUE () (IF *DEBUG-CONTINUE* (INVOKE-RESTART-INTERACTIVELY *DEBUG-CONTINUE*) (FORMAT T "~&There is no way to continue.~%"))) (DEFINE-DEBUG-COMMAND :ERROR () (FORMAT T "~&~A~%" *DEBUG-CONDITION*)) (DEFINE-DEBUG-COMMAND :HELP () (FORMAT T "~&You are in a portable debugger.~ ~%Type a debugger command or a form to evaluate.~ ~%Commands are:~%") (SHOW-RESTARTS *DEBUG-RESTARTS* *NUMBER-OF-DEBUG-RESTARTS* 16) (FORMAT T "~& :EVAL form Evaluate a form.~ ~% :HELP Show this text.~%") (IF *DEBUG-ABORT* (FORMAT T "~& :ABORT Exit by ABORT.~%")) (IF *DEBUG-CONTINUE* (FORMAT T "~& :CONTINUE Exit by CONTINUE.~%")) (FORMAT T "~& :ERROR Reprint error message.~%")) (defvar *debug-command-prefix* ":") (DEFUN SHOW-RESTARTS (&OPTIONAL (RESTARTS *DEBUG-RESTARTS*) (MAX *NUMBER-OF-DEBUG-RESTARTS*) TARGET-COLUMN) (UNLESS MAX (SETQ MAX (LENGTH RESTARTS))) (WHEN RESTARTS (DO ((W (IF TARGET-COLUMN (- TARGET-COLUMN 3) (CEILING (LOG MAX 10)))) (P RESTARTS (CDR P)) (I 0 (1+ I))) ((OR (NOT P) (= I MAX))) (FORMAT T "~& ~A~A " *debug-command-prefix* (LET ((S (FORMAT NIL "~D" (+ I 1)))) (WITH-OUTPUT-TO-STRING (STR) (FORMAT STR "~A" S) (DOTIMES (I (- W (LENGTH S))) (WRITE-CHAR #\Space STR))))) (IF (EQ (CAR P) *DEBUG-ABORT*) (FORMAT T "(Abort) ")) (IF (EQ (CAR P) *DEBUG-CONTINUE*) (FORMAT T "(Continue) ")) (FORMAT T "~A" (CAR P)) (FORMAT T "~%")))) (defvar *DEBUGGER-HOOK* nil) (defvar *debugger-function* 'STANDARD-DEBUGGER) (DEFUN INVOKE-DEBUGGER (&OPTIONAL (DATUM "Debug") &REST ARGUMENTS) (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'DEBUG))) (WHEN *DEBUGGER-HOOK* (LET ((HOOK *DEBUGGER-HOOK*) (*DEBUGGER-HOOK* NIL)) (FUNCALL HOOK CONDITION HOOK))) (funcall *debugger-function* CONDITION))) (DEFUN STANDARD-DEBUGGER (CONDITION) (LET* ((*DEBUG-LEVEL* (1+ *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* CONDITION)) (FORMAT T "~&~A~%" CONDITION) (SHOW-RESTARTS) (DO ((COMMAND (READ-DEBUG-COMMAND) (READ-DEBUG-COMMAND))) (NIL) (EXECUTE-DEBUGGER-COMMAND (CAR COMMAND) (CDR COMMAND) *DEBUG-LEVEL*)))) (DEFUN EXECUTE-DEBUGGER-COMMAND (CMD ARGS LEVEL) (WITH-SIMPLE-RESTART (ABORT "Return to debug level ~D." LEVEL) (COND ((NOT CMD)) ((INTEGERP CMD) (COND ((AND (PLUSP CMD) (< CMD (+ *NUMBER-OF-DEBUG-RESTARTS* 1))) (LET ((RESTART (NTH (- CMD 1) *DEBUG-RESTARTS*))) (IF ARGS (APPLY #'INVOKE-RESTART RESTART (MAPCAR *DEBUG-EVAL* ARGS)) (INVOKE-RESTART-INTERACTIVELY RESTART)))) (T (FORMAT T "~&No such restart.")))) (T (LET ((FN (DEBUG-COMMAND CMD))) (IF FN (COND ((NOT (= (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD))) (FORMAT T "~&Too ~:[few~;many~] arguments to ~A." (> (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD)) CMD)) (T (APPLY FN ARGS))) (FORMAT T "~&~S is not a debugger command.~%" CMD)))))))