1 |
|
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- |
2 |
|
|
3 |
|
(in-package "CONDITIONS") |
4 |
|
|
5 |
|
(DEFVAR *DEBUG-LEVEL* 0) |
6 |
|
(DEFVAR *DEBUG-ABORT* NIL) |
7 |
|
(DEFVAR *DEBUG-CONTINUE* NIL) |
8 |
|
(DEFVAR *DEBUG-CONDITION* NIL) |
9 |
|
(DEFVAR *DEBUG-RESTARTS* NIL) |
10 |
|
(DEFVAR *NUMBER-OF-DEBUG-RESTARTS* 0) |
11 |
|
(DEFVAR *DEBUG-EVAL* 'EVAL) |
12 |
|
(DEFVAR *DEBUG-PRINT* #'(LAMBDA (VALUES) (FORMAT T "~&~{~S~^,~%~}" VALUES))) |
13 |
|
|
14 |
|
(DEFMACRO DEBUG-COMMAND (X) `(GET ,X 'DEBUG-COMMAND)) |
15 |
|
(DEFMACRO DEBUG-COMMAND-ARGUMENT-COUNT (X) `(GET ,X 'DEBUG-COMMAND-ARGUMENT-COUNT)) |
16 |
|
|
17 |
|
(DEFMACRO DEFINE-DEBUG-COMMAND (NAME BVL &REST BODY) |
18 |
|
`(PROGN (SETF (DEBUG-COMMAND ',NAME) #'(LAMBDA ,BVL ,@BODY)) |
19 |
|
(SETF (DEBUG-COMMAND-ARGUMENT-COUNT ',NAME) ,(LENGTH BVL)) |
20 |
|
',NAME)) |
21 |
|
|
22 |
|
(DEFUN READ-DEBUG-COMMAND () |
23 |
|
(FORMAT T "~&Debug ~D> " *DEBUG-LEVEL*) |
24 |
|
(COND ((CHAR= (PEEK-CHAR T) #\:) |
25 |
|
(READ-CHAR) ;Eat the ":" so that ":1" reliably reads a number. |
26 |
|
(WITH-INPUT-FROM-STRING (STREAM (READ-LINE)) |
27 |
|
(LET ((EOF (LIST NIL))) |
28 |
|
(DO ((FORM (LET ((*PACKAGE* (FIND-PACKAGE "KEYWORD"))) |
29 |
|
(READ STREAM NIL EOF)) |
30 |
|
(READ STREAM NIL EOF)) |
31 |
|
(L '() (CONS FORM L))) |
32 |
|
((EQ FORM EOF) (NREVERSE L)))))) |
33 |
|
(T |
34 |
|
(LIST :EVAL (READ))))) |
35 |
|
|
36 |
|
(DEFINE-DEBUG-COMMAND :EVAL (FORM) |
37 |
|
(FUNCALL *DEBUG-PRINT* (MULTIPLE-VALUE-LIST (FUNCALL *DEBUG-EVAL* FORM)))) |
38 |
|
|
39 |
|
(DEFINE-DEBUG-COMMAND :ABORT () |
40 |
|
(IF *DEBUG-ABORT* |
41 |
|
(INVOKE-RESTART-INTERACTIVELY *DEBUG-ABORT*) |
42 |
|
(FORMAT T "~&There is no way to abort.~%"))) |
43 |
|
|
44 |
|
(DEFINE-DEBUG-COMMAND :CONTINUE () |
45 |
|
(IF *DEBUG-CONTINUE* |
46 |
|
(INVOKE-RESTART-INTERACTIVELY *DEBUG-CONTINUE*) |
47 |
|
(FORMAT T "~&There is no way to continue.~%"))) |
48 |
|
|
49 |
|
(DEFINE-DEBUG-COMMAND :ERROR () |
50 |
|
(FORMAT T "~&~A~%" *DEBUG-CONDITION*)) |
51 |
|
|
52 |
|
(DEFINE-DEBUG-COMMAND :HELP () |
53 |
|
(FORMAT T "~&You are in a portable debugger.~ |
54 |
|
~%Type a debugger command or a form to evaluate.~ |
55 |
|
~%Commands are:~%") |
56 |
|
(SHOW-RESTARTS *DEBUG-RESTARTS* *NUMBER-OF-DEBUG-RESTARTS* 16) |
57 |
|
(FORMAT T "~& :EVAL form Evaluate a form.~ |
58 |
|
~% :HELP Show this text.~%") |
59 |
|
(IF *DEBUG-ABORT* (FORMAT T "~& :ABORT Exit by ABORT.~%")) |
60 |
|
(IF *DEBUG-CONTINUE* (FORMAT T "~& :CONTINUE Exit by CONTINUE.~%")) |
61 |
|
(FORMAT T "~& :ERROR Reprint error message.~%")) |
62 |
|
|
63 |
|
|
64 |
|
|
65 |
|
(defvar *debug-command-prefix* ":") |
66 |
|
|
67 |
|
(DEFUN SHOW-RESTARTS (&OPTIONAL (RESTARTS *DEBUG-RESTARTS*) |
68 |
|
(MAX *NUMBER-OF-DEBUG-RESTARTS*) |
69 |
|
TARGET-COLUMN) |
70 |
|
(UNLESS MAX (SETQ MAX (LENGTH RESTARTS))) |
71 |
|
(WHEN RESTARTS |
72 |
|
(DO ((W (IF TARGET-COLUMN |
73 |
|
(- TARGET-COLUMN 3) |
74 |
|
(CEILING (LOG MAX 10)))) |
75 |
|
(P RESTARTS (CDR P)) |
76 |
|
(I 0 (1+ I))) |
77 |
|
((OR (NOT P) (= I MAX))) |
78 |
|
(FORMAT T "~& ~A~A " |
79 |
|
*debug-command-prefix* |
80 |
|
(LET ((S (FORMAT NIL "~D" (+ I 1)))) |
81 |
|
(WITH-OUTPUT-TO-STRING (STR) |
82 |
|
(FORMAT STR "~A" S) |
83 |
|
(DOTIMES (I (- W (LENGTH S))) |
84 |
|
(WRITE-CHAR #\Space STR))))) |
85 |
|
(IF (EQ (CAR P) *DEBUG-ABORT*) (FORMAT T "(Abort) ")) |
86 |
|
(IF (EQ (CAR P) *DEBUG-CONTINUE*) (FORMAT T "(Continue) ")) |
87 |
|
(FORMAT T "~A" (CAR P)) |
88 |
|
(FORMAT T "~%")))) |
89 |
|
|
90 |
|
(defvar *DEBUGGER-HOOK* nil) |
91 |
|
(defvar *debugger-function* 'STANDARD-DEBUGGER) |
92 |
|
|
93 |
|
(DEFUN INVOKE-DEBUGGER (&OPTIONAL (DATUM "Debug") &REST ARGUMENTS) |
94 |
|
(LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'DEBUG))) |
95 |
|
(WHEN *DEBUGGER-HOOK* |
96 |
|
(LET ((HOOK *DEBUGGER-HOOK*) |
97 |
|
(*DEBUGGER-HOOK* NIL)) |
98 |
|
(FUNCALL HOOK CONDITION HOOK))) |
99 |
|
(funcall *debugger-function* CONDITION))) |
100 |
|
|
101 |
|
(DEFUN STANDARD-DEBUGGER (CONDITION) |
102 |
|
(LET* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*)) |
103 |
|
(*DEBUG-RESTARTS* (COMPUTE-RESTARTS)) |
104 |
|
(*NUMBER-OF-DEBUG-RESTARTS* (LENGTH *DEBUG-RESTARTS*)) |
105 |
|
(*DEBUG-ABORT* (FIND-RESTART 'ABORT)) |
106 |
|
(*DEBUG-CONTINUE* (OR (LET ((C (FIND-RESTART 'CONTINUE))) |
107 |
|
(IF (OR (NOT *DEBUG-CONTINUE*) |
108 |
|
(NOT (EQ *DEBUG-CONTINUE* C))) |
109 |
|
C NIL)) |
110 |
|
(LET ((C (IF *DEBUG-RESTARTS* |
111 |
|
(FIRST *DEBUG-RESTARTS*) NIL))) |
112 |
|
(IF (NOT (EQ C *DEBUG-ABORT*)) C NIL)))) |
113 |
|
(*DEBUG-CONDITION* CONDITION)) |
114 |
|
(FORMAT T "~&~A~%" CONDITION) |
115 |
|
(SHOW-RESTARTS) |
116 |
|
(DO ((COMMAND (READ-DEBUG-COMMAND) |
117 |
|
(READ-DEBUG-COMMAND))) |
118 |
|
(NIL) |
119 |
|
(EXECUTE-DEBUGGER-COMMAND (CAR COMMAND) (CDR COMMAND) *DEBUG-LEVEL*)))) |
120 |
|
|
121 |
|
(DEFUN EXECUTE-DEBUGGER-COMMAND (CMD ARGS LEVEL) |
122 |
|
(WITH-SIMPLE-RESTART (ABORT "Return to debug level ~D." LEVEL) |
123 |
|
(COND ((NOT CMD)) |
124 |
|
((INTEGERP CMD) |
125 |
|
(COND ((AND (PLUSP CMD) |
126 |
|
(< CMD (+ *NUMBER-OF-DEBUG-RESTARTS* 1))) |
127 |
|
(LET ((RESTART (NTH (- CMD 1) *DEBUG-RESTARTS*))) |
128 |
|
(IF ARGS |
129 |
|
(APPLY #'INVOKE-RESTART RESTART (MAPCAR *DEBUG-EVAL* ARGS)) |
130 |
|
(INVOKE-RESTART-INTERACTIVELY RESTART)))) |
131 |
|
(T |
132 |
|
(FORMAT T "~&No such restart.")))) |
133 |
|
(T |
134 |
|
(LET ((FN (DEBUG-COMMAND CMD))) |
135 |
|
(IF FN |
136 |
|
(COND ((NOT (= (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD))) |
137 |
|
(FORMAT T "~&Too ~:[few~;many~] arguments to ~A." |
138 |
|
(> (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD)) |
139 |
|
CMD)) |
140 |
|
(T |
141 |
|
(APPLY FN ARGS))) |
142 |
|
(FORMAT T "~&~S is not a debugger command.~%" CMD))))))) |
143 |
|
|