/[gcl]/gcl/clcs/gcl_clcs_debugger.lisp
ViewVC logotype

Diff of /gcl/clcs/gcl_clcs_debugger.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri May 6 21:56:54 2005 UTC revision 1.2 by camm, Sat May 7 02:52:28 2005 UTC
# Line 0  Line 1 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26