← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to clcs/clcs_debugger.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
clcs/clcs_debugger.lisp
 
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