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

Diff of /gcl/clcs/gcl_clcs_top_patches.lisp

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

revision 1.1 by camm, Fri May 6 21:56:55 2005 UTC revision 1.2 by camm, Sat May 7 02:52:28 2005 UTC
# Line 0  Line 1 
1    
2    (in-package "CONDITIONS")
3    
4    (import '(with-simple-restart abort continue compute-restarts
5              *debug-level* *debug-restarts* *number-of-debug-restarts*
6              *debug-abort* *debug-continue* *debug-condition* *debug-eval*
7              find-restart invoke-restart invoke-restart-interactively
8              restart-name ignore-errors show-restarts conditionp)
9            "SYSTEM")
10    
11    (in-package "SYSTEM")
12    
13    (defvar *abort-restarts* nil)
14    
15    (defmacro with-clcs-break-level-bindings (&body forms)
16      `(let* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*))
17              (debug-level *DEBUG-LEVEL*)
18              (*DEBUG-RESTARTS* (COMPUTE-RESTARTS))
19              (*NUMBER-OF-DEBUG-RESTARTS* (LENGTH *DEBUG-RESTARTS*))
20              (*DEBUG-ABORT*    (FIND-RESTART 'ABORT))
21              (*DEBUG-CONTINUE* (OR (LET ((C (FIND-RESTART 'CONTINUE)))
22                                      (IF (OR (NOT *DEBUG-CONTINUE*)
23                                              (NOT (EQ *DEBUG-CONTINUE* C)))
24                                          C NIL))
25                                    (LET ((C (IF *DEBUG-RESTARTS*
26                                                 (FIRST *DEBUG-RESTARTS*) NIL)))
27                                      (IF (NOT (EQ C *DEBUG-ABORT*)) C NIL))))
28              (*DEBUG-CONDITION* (if (conditionp at) at *DEBUG-CONDITION*))
29              (*abort-restarts* (let ((abort-list nil))
30                                  (dolist (restart *DEBUG-RESTARTS*)
31                                    (when (eq 'abort (restart-name restart))
32                                      (push restart abort-list)))
33                                  (nreverse abort-list))))
34         ,@forms))
35    
36    (defun clcs-break-level-invoke-restart (-)
37      (COND ((AND (PLUSP -)
38                  (< - (+ *NUMBER-OF-DEBUG-RESTARTS* 1)))
39             (LET ((RESTART (NTH (- - 1) *DEBUG-RESTARTS*)))
40               (INVOKE-RESTART-INTERACTIVELY RESTART)))
41            (T
42             (FORMAT T "~&No such restart."))))
43    
44    ;; From akcl-1-530, changes marked with ;***
45    (defun clcs-break-level (at &optional env)
46      (let* ((*break-message* (if (or (stringp at) (conditionp at)) ;***
47                                  at *break-message*))  ;***
48             (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*)) ;***
49             (*quit-tag* nil)    ;***
50             (*break-level* (if (conditionp at) (cons t *break-level*) *break-level*))
51             (*ihs-base* (1+ *ihs-top*))
52             (*ihs-top* (1- (ihs-top)))
53             (*current-ihs* *ihs-top*)
54             (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
55             (*frs-top* (frs-top))
56             (*break-env* nil)
57             ;;(be *break-enable*) ;***
58             ;;(*break-enable*               ;***
59              ;;(progn                       ;***
60                ;;(if (stringp at) nil be))) ;***
61             ;;(*standard-input* *terminal-io*)
62             (*readtable* (or *break-readtable* *readtable*))
63             (*read-suppress* nil)
64             (+ +) (++ ++) (+++ +++)
65             (- -)
66             (* *) (** **) (*** ***)
67             (/ /) (// //) (/// ///)
68             )
69        ;;(terpri *error-output*)
70        (with-clcs-break-level-bindings ;***
71          (if (consp at)
72              (set-back at env)
73              (with-simple-restart (abort "Return to debug level ~D." DEBUG-LEVEL) ;***
74                (format *debug-io* "~&~A~2%" *break-message*) ;***
75                (when (> (length *link-array*) 0)
76                  (format *debug-io*
77                          "Fast links are on: do (use-fast-links nil) for debugging~%"))
78                (set-current)               ;***
79                (setq *no-prompt* nil)
80                (show-restarts)))           ;***
81          (catch-fatal 1)
82          (setq *interrupt-enable* t)
83          (loop
84           (setq +++ ++ ++ + + -)
85           (cond (*no-prompt* (setq *no-prompt* nil))
86                 (t
87                  (format *debug-io* "~&~a~a>~{~*>~}"
88                          (if (stringp at) "" "dbl:")
89                          (if (eq *package* (find-package 'user)) ""
90                            (package-name *package*))
91                          *break-level*)))
92           (unless ;***
93            (with-simple-restart (abort "Return to debug level ~D." DEBUG-LEVEL) ;***
94              (not
95                (catch 'step-continue
96                  (setq - (locally (declare (notinline read))
97                            (dbl-read *debug-io* nil *top-eof*)))
98                  (when (eq - *top-eof*) (bye))
99                  (let* ( break-command
100                         (values
101                          (multiple-value-list
102                              (LOCALLY (declare (notinline break-call evalhook))
103                                (if (or (keywordp -) (integerp -)) ;***
104                                    (setq - (cons - nil)))
105                                (cond ((and (consp -) (keywordp (car -)))
106                                       (setq break-command t)
107                                       (break-call (car -) (cdr -)))
108                                      ((and (consp -) (integerp (car -))) ;***
109                                       (setq break-command t) ;***
110                                       (clcs-break-level-invoke-restart (car -))) ;***
111                                      (t (evalhook - nil nil *break-env*))))))) ;***
112                    (setq /// // // / / values *** ** ** * * (car /))
113                    (fresh-line *debug-io*)
114                    (dolist (val /)
115                      (locally (declare (notinline prin1)) (prin1 val *debug-io*))
116                      (terpri *debug-io*)))
117                  nil)))                    ;***
118            (terpri *debug-io*)
119            (break-current))))))
120    
121    (defun clcs-terminal-interrupt (correctablep)
122      (if correctablep
123          (cerror "Continues execution." "Console interrupt.")
124          (error "Console interrupt -- cannot continue.")))
125    
126    (defun clcs-break-quit (&optional (level 0))
127      (let ((abort (nth level (cons (find-restart 'conditions::gcl-top-restart) (reverse *abort-restarts*)))))
128        (when abort (invoke-restart-interactively abort)))
129      (break-current))
130    
131    (setq conditions::*debugger-function* 'break-level)
132    (setq conditions::*debug-command-prefix* "")
133    
134    (defun break-resume ()
135      (and *debug-continue* (invoke-restart *debug-continue*)))
136    
137    (putprop :r 'break-resume 'break-command)
138    (putprop :s 'show-restarts 'break-command)
139    
140    (defun break-help ()
141      (format *debug-io* "
142    Break-loop Command Summary ([] indicates optional arg)
143    --------------------------
144    
145    :bl [j]     show local variables and their values, or segment of vs if compiled
146                  in j stack frames starting at the current one.
147    :bt [n]     BACKTRACE [n steps]
148    :down [i]   DOWN i frames (one if no i)
149    :env        describe ENVIRONMENT of this stack frame (for interpreted).
150    :fr [n]     show frame n
151    :loc [i]    return i'th local of this frame if its function is compiled (si::loc i)
152    :r          RESUME (return from the current break loop).
153    :up [i]     UP i frames (one if no i)
154    
155    Example: print a bactrace of the last 4 frames
156    
157    >>:bt 4
158    
159    Note:  (use-fast-links nil) makes all non system function calls
160    be recorded in the stack.   (use-fast-links t) is the default
161    
162    
163    Low level commands:
164    ------------------
165    :p [i]           make current the i'th PREVIOUS frame (in list show by :b)
166    :n [i]           make current the i'th NEXT frame (in list show by :b)
167    :go [ihs-index]  make current the frame corresponding ihs-index
168    :m               print the last break message.
169    :s               show restarts.
170    :c               show function of the current ihs frame.
171    :q [i]           quit to top level
172    :r               resume from this break loop.
173    :b               full backtrace of all functions and special forms.
174    :bs [name]       backward search for frame named 'name'
175    :fs  [name]      search for frame named 'name'
176    :vs [from] [to]  Show value stack between FROM and TO
177    :ihs [from] [to] Show Invocation History Stack
178    :bds ['v1 'v2 ..]Show previous special bindings of v1, v2,.. or all if no v1
179    
180    ")
181              (values)
182              )

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