1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
4 | ;;; This file is part of OpenMCL. |
---|
5 | ;;; |
---|
6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
13 | ;;; |
---|
14 | ;;; The LLGPL is also available online at |
---|
15 | ;;; http://opensource.franz.com/preamble.html |
---|
16 | |
---|
17 | ; l1-readloop-lds.lisp |
---|
18 | |
---|
19 | (in-package "CCL") |
---|
20 | |
---|
21 | |
---|
22 | |
---|
23 | (defun toplevel-loop () |
---|
24 | (loop |
---|
25 | (if (eq (catch :toplevel |
---|
26 | (read-loop :break-level 0 )) $xstkover) |
---|
27 | (format t "~&;[Stacks reset due to overflow.]") |
---|
28 | (when (eq *current-process* *initial-process*) |
---|
29 | (toplevel))))) |
---|
30 | |
---|
31 | |
---|
32 | (defvar *defined-toplevel-commands* ()) |
---|
33 | (defvar *active-toplevel-commands* ()) |
---|
34 | |
---|
35 | (defun %define-toplevel-command (group-name key name fn doc args) |
---|
36 | (let* ((group (or (assoc group-name *defined-toplevel-commands*) |
---|
37 | (car (push (list group-name) |
---|
38 | *defined-toplevel-commands*)))) |
---|
39 | (pair (assoc key (cdr group) :test #'eq))) |
---|
40 | (if pair |
---|
41 | (rplacd pair (list* fn doc args)) |
---|
42 | (push (cons key (list* fn doc args)) (cdr group)))) |
---|
43 | name) |
---|
44 | |
---|
45 | (define-toplevel-command |
---|
46 | :global y (&optional p) "Yield control of terminal-input to process |
---|
47 | whose name or ID matches <p>, or to any process if <p> is null" |
---|
48 | (%%yield-terminal-to (if p (find-process p)))) ;may be nil |
---|
49 | |
---|
50 | |
---|
51 | (define-toplevel-command |
---|
52 | :global kill (p) "Kill process whose name or ID matches <p>" |
---|
53 | (let* ((proc (find-process p))) |
---|
54 | (if proc |
---|
55 | (process-kill proc)))) |
---|
56 | |
---|
57 | (define-toplevel-command |
---|
58 | :global proc (&optional p) "Show information about specified process <p>/all processes" |
---|
59 | (flet ((show-process-info (proc) |
---|
60 | (format t "~&~d : ~a ~a ~20t[~a] " |
---|
61 | (process-serial-number proc) |
---|
62 | (if (eq proc *current-process*) |
---|
63 | "->" |
---|
64 | " ") |
---|
65 | (process-name proc) |
---|
66 | (process-whostate proc)) |
---|
67 | (let* ((suspend-count (process-suspend-count proc))) |
---|
68 | (if (and suspend-count (not (eql 0 suspend-count))) |
---|
69 | (format t " (Suspended)"))) |
---|
70 | (let* ((terminal-input-shared-resource |
---|
71 | (if (typep *terminal-io* 'two-way-stream) |
---|
72 | (input-stream-shared-resource |
---|
73 | (two-way-stream-input-stream *terminal-io*))))) |
---|
74 | (if (and terminal-input-shared-resource |
---|
75 | (%shared-resource-requestor-p |
---|
76 | terminal-input-shared-resource proc)) |
---|
77 | (format t " (Requesting terminal input)"))) |
---|
78 | (fresh-line))) |
---|
79 | (if p |
---|
80 | (let* ((proc (find-process p))) |
---|
81 | (if (null proc) |
---|
82 | (format t "~&;; not found - ~s" p) |
---|
83 | (show-process-info proc))) |
---|
84 | (dolist (proc (all-processes) (values)) |
---|
85 | (show-process-info proc))))) |
---|
86 | |
---|
87 | (define-toplevel-command :global cd (dir) "Change to directory DIR" (setf (current-directory) dir) (toplevel-print (list (current-directory)))) |
---|
88 | |
---|
89 | (define-toplevel-command :global pwd () "Print the pathame of the current directory" (toplevel-print (list (current-directory)))) |
---|
90 | |
---|
91 | |
---|
92 | |
---|
93 | (define-toplevel-command :break pop () "exit current break loop" (abort-break)) |
---|
94 | (define-toplevel-command :break go () "continue" (continue)) |
---|
95 | (define-toplevel-command :break q () "return to toplevel" (toplevel)) |
---|
96 | (define-toplevel-command :break r () "list restarts" |
---|
97 | (format t "~& (:C <n>) can be used to invoke one of the following restarts in this break loop:") |
---|
98 | (let* ((r (apply #'vector (compute-restarts *break-condition*)))) |
---|
99 | (dotimes (i (length r) (terpri)) |
---|
100 | (format *debug-io* "~&~d. ~a" i (svref r i))))) |
---|
101 | |
---|
102 | ;;; From Marco Baringer 2003/03/18 |
---|
103 | |
---|
104 | (define-toplevel-command :break set (n frame value) "Set <n>th item of frame <frame> to <value>" |
---|
105 | (let* ((frame-sp (nth-raw-frame frame *break-frame* nil))) |
---|
106 | (if frame-sp |
---|
107 | (toplevel-print (list (set-nth-value-in-frame frame-sp n nil value))) |
---|
108 | (format *debug-io* "No frame with number ~D~%" frame)))) |
---|
109 | |
---|
110 | (define-toplevel-command :break nframes () |
---|
111 | "print the number of stack frames accessible from this break loop" |
---|
112 | (do* ((p *break-frame* (parent-frame p nil)) |
---|
113 | (i 0 (1+ i)) |
---|
114 | (last (last-frame-ptr))) |
---|
115 | ((eql p last) (toplevel-print (list i))))) |
---|
116 | |
---|
117 | (define-toplevel-command :global ? () "help" |
---|
118 | (dolist (g *active-toplevel-commands*) |
---|
119 | (dolist (c (cdr g)) |
---|
120 | (let* ((command (car c)) |
---|
121 | (doc (caddr c)) |
---|
122 | (args (cdddr c))) |
---|
123 | (if args |
---|
124 | (format t "~& (~S~{ ~A~}) ~8T~A" command args doc) |
---|
125 | (format t "~& ~S ~8T~A" command doc)))))) |
---|
126 | |
---|
127 | |
---|
128 | (define-toplevel-command :break b (&key start count show-frame-contents) "backtrace" |
---|
129 | (when *break-frame* |
---|
130 | (print-call-history :detailed-p show-frame-contents |
---|
131 | :origin *break-frame* |
---|
132 | :count count |
---|
133 | :start-frame-number (or start 0)))) |
---|
134 | |
---|
135 | (define-toplevel-command :break c (n) "Choose restart <n>" |
---|
136 | (select-restart n)) |
---|
137 | |
---|
138 | (define-toplevel-command :break f (n) "Show backtrace frame <n>" |
---|
139 | (print-call-history :origin *break-frame* |
---|
140 | :start-frame-number n |
---|
141 | :count 1 |
---|
142 | :detailed-p t)) |
---|
143 | |
---|
144 | (define-toplevel-command :break raw (n) "Show raw contents of backtrace frame <n>" |
---|
145 | (print-call-history :origin *break-frame* |
---|
146 | :start-frame-number n |
---|
147 | :count 1 |
---|
148 | :detailed-p :raw)) |
---|
149 | |
---|
150 | (define-toplevel-command :break v (n frame-number) "Return value <n> in frame <frame-number>" |
---|
151 | (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) |
---|
152 | (if frame-sp |
---|
153 | (toplevel-print (list (nth-value-in-frame frame-sp n nil)))))) |
---|
154 | |
---|
155 | (define-toplevel-command :break arg (name frame-number) "Return value of argument named <name> in frame <frame-number>" |
---|
156 | (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) |
---|
157 | (when frame-sp |
---|
158 | (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) |
---|
159 | (when (and lfun pc) |
---|
160 | (let* ((unavailable (cons nil nil))) |
---|
161 | (declare (dynamic-extent unavailable)) |
---|
162 | (let* ((value (arg-value nil frame-sp lfun pc unavailable name))) |
---|
163 | (if (eq value unavailable) |
---|
164 | (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number) |
---|
165 | (toplevel-print (list value)))))))))) |
---|
166 | |
---|
167 | (define-toplevel-command :break set-arg (name frame-number new) "Set value of argument named <name> in frame <frame-number> to value <new>." |
---|
168 | (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) |
---|
169 | (when frame-sp |
---|
170 | (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) |
---|
171 | (when (and lfun pc) |
---|
172 | (or (set-arg-value nil frame-sp lfun pc name new) |
---|
173 | (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number))))))) |
---|
174 | |
---|
175 | |
---|
176 | (define-toplevel-command :break local (name frame-number) "Return value of local denoted by <name> in frame <frame-number> <name> can either be a symbol - in which case the most recent |
---|
177 | binding of that symbol is used - or an integer index into the frame's set of local bindings." |
---|
178 | (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) |
---|
179 | (when frame-sp |
---|
180 | (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) |
---|
181 | (when (and lfun pc) |
---|
182 | (let* ((unavailable (cons nil nil))) |
---|
183 | (declare (dynamic-extent unavailable)) |
---|
184 | (let* ((value (local-value nil frame-sp lfun pc unavailable name))) |
---|
185 | (if (eq value unavailable) |
---|
186 | (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number) |
---|
187 | (toplevel-print (list value)))))))))) |
---|
188 | |
---|
189 | (define-toplevel-command :break set-local (name frame-number new) "Set value of argument denoted <name> (see :LOCAL) in frame <frame-number> to value <new>." |
---|
190 | (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) |
---|
191 | (when frame-sp |
---|
192 | (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) |
---|
193 | (when (and lfun pc) |
---|
194 | (or (set-local-value nil frame-sp lfun pc name new) |
---|
195 | (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number))))))) |
---|
196 | |
---|
197 | |
---|
198 | (define-toplevel-command :break form (frame-number) |
---|
199 | "Return a form which looks like the call which established the stack frame identified by <frame-number>. This is only well-defined in certain cases: when the function is globally named and not a lexical closure and when it was compiled with *SAVE-LOCAL-SYMBOLS* in effect." |
---|
200 | (let* ((form (dbg-form frame-number))) |
---|
201 | (when form |
---|
202 | (let* ((*print-level* *backtrace-print-level*) |
---|
203 | (*print-length* *backtrace-print-length*)) |
---|
204 | (toplevel-print (list form)))))) |
---|
205 | |
---|
206 | ;;; Ordinarily, form follows function. |
---|
207 | (define-toplevel-command :break function (frame-number) |
---|
208 | "Returns the function invoked in backtrace frame <frame-number>. This may be useful for, e.g., disassembly" |
---|
209 | (let* ((cfp (nth-raw-frame frame-number *break-frame* nil))) |
---|
210 | (when (and cfp (not (catch-csp-p cfp nil))) |
---|
211 | (let* ((function (cfp-lfun cfp))) |
---|
212 | (when function |
---|
213 | (toplevel-print (list function))))))) |
---|
214 | |
---|
215 | |
---|
216 | |
---|
217 | |
---|
218 | |
---|
219 | |
---|
220 | |
---|
221 | (defun %use-toplevel-commands (group-name) |
---|
222 | ;; Push the whole group |
---|
223 | (pushnew (assoc group-name *defined-toplevel-commands*) |
---|
224 | *active-toplevel-commands* |
---|
225 | :key #'(lambda (x) (car x)))) ; #'car not defined yet ... |
---|
226 | |
---|
227 | (%use-toplevel-commands :global) |
---|
228 | |
---|
229 | (defun check-toplevel-command (form) |
---|
230 | (let* ((cmd (if (consp form) (car form) form)) |
---|
231 | (args (if (consp form) (cdr form)))) |
---|
232 | (if (keywordp cmd) |
---|
233 | (dolist (g *active-toplevel-commands*) |
---|
234 | (when |
---|
235 | (let* ((pair (assoc cmd (cdr g)))) |
---|
236 | (if pair |
---|
237 | (progn (apply (cadr pair) args) |
---|
238 | t))) |
---|
239 | (return t)))))) |
---|
240 | |
---|
241 | (defparameter *quit-on-eof* nil) |
---|
242 | |
---|
243 | ;;; This is the part common to toplevel loop and inner break loops. |
---|
244 | (defun read-loop (&key (input-stream *standard-input*) |
---|
245 | (output-stream *standard-output*) |
---|
246 | (break-level *break-level*) |
---|
247 | (prompt-function #'(lambda (stream) (print-listener-prompt stream t)))) |
---|
248 | (let* ((*break-level* break-level) |
---|
249 | (*last-break-level* break-level) |
---|
250 | *loading-file-source-file* |
---|
251 | *in-read-loop* |
---|
252 | *** ** * +++ ++ + /// // / - |
---|
253 | (eof-value (cons nil nil))) |
---|
254 | (declare (dynamic-extent eof-value)) |
---|
255 | (loop |
---|
256 | (restart-case |
---|
257 | (catch :abort ;last resort... |
---|
258 | (loop |
---|
259 | (catch-cancel |
---|
260 | (loop |
---|
261 | (setq *in-read-loop* nil |
---|
262 | *break-level* break-level) |
---|
263 | (multiple-value-bind (form path print-result) |
---|
264 | (toplevel-read :input-stream input-stream |
---|
265 | :output-stream output-stream |
---|
266 | :prompt-function prompt-function |
---|
267 | :eof-value eof-value) |
---|
268 | (if (eq form eof-value) |
---|
269 | (if (and (not *batch-flag*) |
---|
270 | (not *quit-on-eof*) |
---|
271 | (eof-transient-p (stream-device input-stream :input))) |
---|
272 | (progn |
---|
273 | (stream-clear-input input-stream) |
---|
274 | (abort-break)) |
---|
275 | (exit-interactive-process *current-process*)) |
---|
276 | (or (check-toplevel-command form) |
---|
277 | (let* ((values (toplevel-eval form path))) |
---|
278 | (if print-result (toplevel-print values)))))))) |
---|
279 | (format *terminal-io* "~&Cancelled"))) |
---|
280 | (abort () :report (lambda (stream) |
---|
281 | (if (eq break-level 0) |
---|
282 | (format stream "Return to toplevel.") |
---|
283 | (format stream "Return to break level ~D." break-level))) |
---|
284 | #| ; Handled by interactive-abort |
---|
285 | ; go up one more if abort occurred while awaiting/reading input |
---|
286 | (when (and *in-read-loop* (neq break-level 0)) |
---|
287 | (abort)) |
---|
288 | |# |
---|
289 | ) |
---|
290 | (abort-break () |
---|
291 | (unless (eq break-level 0) |
---|
292 | (abort)))) |
---|
293 | (clear-input input-stream) |
---|
294 | (format output-stream "~%")))) |
---|
295 | |
---|
296 | ;;; The first non-whitespace character available on INPUT-STREAM is a colon. |
---|
297 | ;;; Try to interpret the line as a colon command (or possibly just a keyword.) |
---|
298 | (defun read-command-or-keyword (input-stream eof-value) |
---|
299 | (let* ((line (read-line input-stream nil eof-value))) |
---|
300 | (if (eq line eof-value) |
---|
301 | eof-value |
---|
302 | (let* ((in (make-string-input-stream line)) |
---|
303 | (keyword (read in nil eof-value))) |
---|
304 | (if (eq keyword eof-value) |
---|
305 | eof-value |
---|
306 | (if (not (keywordp keyword)) |
---|
307 | keyword |
---|
308 | (collect ((params)) |
---|
309 | (loop |
---|
310 | (let* ((param (read in nil eof-value))) |
---|
311 | (if (eq param eof-value) |
---|
312 | (return |
---|
313 | (let* ((params (params))) |
---|
314 | (if params |
---|
315 | (cons keyword params) |
---|
316 | keyword))) |
---|
317 | (params (eval param)))))))))))) |
---|
318 | |
---|
319 | ;;; Read a form from the specified stream. |
---|
320 | (defun toplevel-read (&key (input-stream *standard-input*) |
---|
321 | (output-stream *standard-output*) |
---|
322 | (prompt-function #'print-listener-prompt) |
---|
323 | (eof-value *eof-value*)) |
---|
324 | (force-output output-stream) |
---|
325 | (funcall prompt-function output-stream) |
---|
326 | (read-toplevel-form input-stream eof-value)) |
---|
327 | |
---|
328 | (defvar *always-eval-user-defvars* nil) |
---|
329 | |
---|
330 | (defun process-single-selection (form) |
---|
331 | (if (and *always-eval-user-defvars* |
---|
332 | (listp form) (eq (car form) 'defvar) (cddr form)) |
---|
333 | `(defparameter ,@(cdr form)) |
---|
334 | form)) |
---|
335 | |
---|
336 | (defun toplevel-eval (form &optional *loading-file-source-file*) |
---|
337 | (setq +++ ++ ++ + + - - form) |
---|
338 | (let* ((package *package*) |
---|
339 | (values (multiple-value-list (cheap-eval-in-environment form nil)))) |
---|
340 | (unless (eq package *package*) |
---|
341 | (application-ui-operation *application* :note-current-package *package*)) |
---|
342 | values)) |
---|
343 | |
---|
344 | (defun toplevel-print (values &optional (out *standard-output*)) |
---|
345 | (setq /// // // / / values) |
---|
346 | (unless (eq (car values) (%unbound-marker)) |
---|
347 | (setq *** ** ** * * (%car values))) |
---|
348 | (when values |
---|
349 | (fresh-line out) |
---|
350 | (dolist (val values) (write val :stream out) (terpri out)))) |
---|
351 | |
---|
352 | (defun print-listener-prompt (stream &optional (force t)) |
---|
353 | (unless *quiet-flag* |
---|
354 | (when (or force (neq *break-level* *last-break-level*)) |
---|
355 | (let* ((*listener-indent* nil)) |
---|
356 | (fresh-line stream) |
---|
357 | (if (%izerop *break-level*) |
---|
358 | (%write-string "?" stream) |
---|
359 | (format stream "~s >" *break-level*))) |
---|
360 | (write-string " " stream) |
---|
361 | (setq *last-break-level* *break-level*))) |
---|
362 | (force-output stream)) |
---|
363 | |
---|
364 | |
---|
365 | ;;; Fairly crude default error-handlingbehavior, and a fairly crude mechanism |
---|
366 | ;;; for customizing it. |
---|
367 | |
---|
368 | (defvar *app-error-handler-mode* :quit |
---|
369 | "one of :quit, :quit-quietly, :listener might be useful.") |
---|
370 | |
---|
371 | (defmethod application-error ((a application) condition error-pointer) |
---|
372 | (case *app-error-handler-mode* |
---|
373 | (:listener (break-loop-handle-error condition error-pointer)) |
---|
374 | (:quit-quietly (quit -1)) |
---|
375 | (:quit (format t "~&Fatal error in ~s : ~a" |
---|
376 | (pathname-name (car *command-line-argument-list*)) |
---|
377 | condition) |
---|
378 | (quit -1)))) |
---|
379 | |
---|
380 | (defun make-application-error-handler (app mode) |
---|
381 | (declare (ignore app)) |
---|
382 | (setq *app-error-handler-mode* mode)) |
---|
383 | |
---|
384 | |
---|
385 | ; You may want to do this anyway even if your application |
---|
386 | ; does not otherwise wish to be a "lisp-development-system" |
---|
387 | (defmethod application-error ((a lisp-development-system) condition error-pointer) |
---|
388 | (break-loop-handle-error condition error-pointer)) |
---|
389 | |
---|
390 | (defun break-loop-handle-error (condition error-pointer) |
---|
391 | (multiple-value-bind (bogus-globals newvals oldvals) (%check-error-globals) |
---|
392 | (dolist (x bogus-globals) |
---|
393 | (set x (funcall (pop newvals)))) |
---|
394 | (when (and *debugger-hook* *break-on-errors*) |
---|
395 | (let ((hook *debugger-hook*) |
---|
396 | (*debugger-hook* nil)) |
---|
397 | (funcall hook condition hook))) |
---|
398 | (%break-message "Error" condition error-pointer) |
---|
399 | (with-terminal-input |
---|
400 | (let* ((s *error-output*)) |
---|
401 | (dolist (bogusness bogus-globals) |
---|
402 | (let ((oldval (pop oldvals))) |
---|
403 | (format s "~&; NOTE: ~S was " bogusness) |
---|
404 | (if (eq oldval (%unbound-marker-8)) |
---|
405 | (format s "unbound") |
---|
406 | (format s "~s" oldval)) |
---|
407 | (format s ", was reset to ~s ." (symbol-value bogusness))))) |
---|
408 | (if *break-on-errors* |
---|
409 | (break-loop condition error-pointer) |
---|
410 | (abort))))) |
---|
411 | |
---|
412 | (defun break (&optional string &rest args) |
---|
413 | "Print a message and invoke the debugger without allowing any possibility |
---|
414 | of condition handling occurring." |
---|
415 | (apply #'%break-in-frame (%get-frame-ptr) string args)) |
---|
416 | |
---|
417 | (defun %break-in-frame (fp &optional string &rest args) |
---|
418 | (flet ((do-break-loop () |
---|
419 | (let ((c (if (typep string 'condition) |
---|
420 | string |
---|
421 | (make-condition 'simple-condition |
---|
422 | :format-control (or string "") |
---|
423 | :format-arguments args)))) |
---|
424 | (cbreak-loop "Break" "Return from BREAK." c fp)))) |
---|
425 | (cond ((%i> *interrupt-level* -1) |
---|
426 | (do-break-loop)) |
---|
427 | (*break-loop-when-uninterruptable* |
---|
428 | (format *error-output* "Break while interrupt-level less than zero; binding to 0 during break-loop.") |
---|
429 | (let ((interrupt-level (interrupt-level))) |
---|
430 | (unwind-protect |
---|
431 | (progn |
---|
432 | (setf (interrupt-level) 0) |
---|
433 | (do-break-loop)) |
---|
434 | (setf (interrupt-level) interrupt-level)))) |
---|
435 | (t (format *error-output* "Break while interrupt-level less than zero; ignored."))))) |
---|
436 | |
---|
437 | |
---|
438 | (defun invoke-debugger (condition &aux (fp (%get-frame-ptr))) |
---|
439 | "Enter the debugger." |
---|
440 | (let ((c (require-type condition 'condition))) |
---|
441 | (when *debugger-hook* |
---|
442 | (let ((hook *debugger-hook*) |
---|
443 | (*debugger-hook* nil)) |
---|
444 | (funcall hook c hook))) |
---|
445 | (%break-message "Debug" c fp) |
---|
446 | (with-terminal-input |
---|
447 | (break-loop c fp)))) |
---|
448 | |
---|
449 | (defun %break-message (msg condition error-pointer &optional (prefixchar #\>)) |
---|
450 | (let ((*print-circle* *error-print-circle*) |
---|
451 | ;(*print-prett*y nil) |
---|
452 | (*print-array* nil) |
---|
453 | (*print-escape* t) |
---|
454 | (*print-gensym* t) |
---|
455 | (*print-length* *backtrace-print-length*) ; ? |
---|
456 | (*print-level* *backtrace-print-level*) ; ? |
---|
457 | (*print-lines* nil) |
---|
458 | (*print-miser-width* nil) |
---|
459 | (*print-readably* nil) |
---|
460 | (*print-right-margin* nil) |
---|
461 | (*signal-printing-errors* nil) |
---|
462 | (s (make-indenting-string-output-stream prefixchar nil))) |
---|
463 | (format s "~A ~A: " prefixchar msg) |
---|
464 | (setf (indenting-string-output-stream-indent s) (column s)) |
---|
465 | ;(format s "~A" condition) ; evil if circle |
---|
466 | (report-condition condition s) |
---|
467 | (if (not (and (typep condition 'simple-program-error) |
---|
468 | (simple-program-error-context condition))) |
---|
469 | (format *error-output* "~&~A~%~A While executing: ~S" |
---|
470 | (get-output-stream-string s) prefixchar (%real-err-fn-name error-pointer)) |
---|
471 | (format *error-output* "~&~A" |
---|
472 | (get-output-stream-string s))) |
---|
473 | (format *error-output* ", in process ~a(~d).~%" (process-name *current-process*) (process-serial-number *current-process*)) |
---|
474 | (force-output *error-output*))) |
---|
475 | ; returns NIL |
---|
476 | |
---|
477 | (defun cbreak-loop (msg cont-string condition error-pointer) |
---|
478 | (let* ((*print-readably* nil)) |
---|
479 | (%break-message msg condition error-pointer) |
---|
480 | (with-terminal-input |
---|
481 | (restart-case (break-loop condition error-pointer) |
---|
482 | (continue () :report (lambda (stream) (write-string cont-string stream)))) |
---|
483 | (fresh-line *error-output*) |
---|
484 | nil))) |
---|
485 | |
---|
486 | (defun warn (condition-or-format-string &rest args) |
---|
487 | "Warn about a situation by signalling a condition formed by DATUM and |
---|
488 | ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart |
---|
489 | exists that causes WARN to immediately return NIL." |
---|
490 | (when (typep condition-or-format-string 'condition) |
---|
491 | (unless (typep condition-or-format-string 'warning) |
---|
492 | (report-bad-arg condition-or-format-string 'warning)) |
---|
493 | (when args |
---|
494 | (error 'type-error :datum args :expected-type 'null |
---|
495 | :format-control "Extra arguments in ~s."))) |
---|
496 | (let ((fp (%get-frame-ptr)) |
---|
497 | (c (require-type (condition-arg condition-or-format-string args 'simple-warning) 'warning))) |
---|
498 | (when *break-on-warnings* |
---|
499 | (cbreak-loop "Warning" "Signal the warning." c fp)) |
---|
500 | (restart-case (signal c) |
---|
501 | (muffle-warning () :report "Skip the warning" (return-from warn nil))) |
---|
502 | (%break-message (if (typep c 'compiler-warning) "Compiler warning" "Warning") c fp #\;) |
---|
503 | )) |
---|
504 | |
---|
505 | (declaim (notinline select-backtrace)) |
---|
506 | |
---|
507 | (defmacro new-backtrace-info (dialog youngest oldest tcr condition current fake db-link level) |
---|
508 | (let* ((cond (gensym))) |
---|
509 | `(let* ((,cond ,condition)) |
---|
510 | (vector ,dialog ,youngest ,oldest ,tcr (cons nil (compute-restarts ,cond)) (%catch-top ,tcr) ,cond ,current ,fake ,db-link ,level)))) |
---|
511 | |
---|
512 | (defun select-backtrace () |
---|
513 | (declare (notinline select-backtrace)) |
---|
514 | ;(require 'new-backtrace) |
---|
515 | (require :inspector) |
---|
516 | (select-backtrace)) |
---|
517 | |
---|
518 | (defvar *break-condition* nil "condition argument to innermost break-loop.") |
---|
519 | (defvar *break-frame* nil "frame-pointer arg to break-loop") |
---|
520 | (defvar *break-loop-when-uninterruptable* t) |
---|
521 | |
---|
522 | (defvar *error-reentry-count* 0) |
---|
523 | |
---|
524 | (defun funcall-with-error-reentry-detection (thunk) |
---|
525 | (let* ((count *error-reentry-count*) |
---|
526 | (*error-reentry-count* (1+ count))) |
---|
527 | (cond ((eql count 0) (funcall thunk)) |
---|
528 | ((eql count 1) (error "Error reporting error")) |
---|
529 | (t (bug "Error reporting error"))))) |
---|
530 | |
---|
531 | |
---|
532 | |
---|
533 | |
---|
534 | (defvar %last-continue% nil) |
---|
535 | (defun break-loop (condition frame-pointer) |
---|
536 | "Never returns" |
---|
537 | (let* ((%handlers% (last %handlers%)) ; firewall |
---|
538 | (*break-frame* frame-pointer) |
---|
539 | (*break-condition* condition) |
---|
540 | (*compiling-file* nil) |
---|
541 | (*backquote-stack* nil) |
---|
542 | (continue (find-restart 'continue)) |
---|
543 | (*continuablep* (unless (eq %last-continue% continue) continue)) |
---|
544 | (%last-continue% continue) |
---|
545 | (*standard-input* *debug-io*) |
---|
546 | (*standard-output* *debug-io*) |
---|
547 | (*signal-printing-errors* nil) |
---|
548 | (*read-suppress* nil) |
---|
549 | (*print-readably* nil)) |
---|
550 | (let* ((context (new-backtrace-info nil |
---|
551 | frame-pointer |
---|
552 | (if *backtrace-contexts* |
---|
553 | (or (child-frame |
---|
554 | (bt.youngest (car *backtrace-contexts*)) |
---|
555 | nil) |
---|
556 | (last-frame-ptr)) |
---|
557 | (last-frame-ptr)) |
---|
558 | (%current-tcr) |
---|
559 | condition |
---|
560 | (%current-frame-ptr) |
---|
561 | #+ppc-target *fake-stack-frames* |
---|
562 | #+x86-target (%current-frame-ptr) |
---|
563 | (db-link) |
---|
564 | (1+ *break-level*))) |
---|
565 | (*backtrace-contexts* (cons context *backtrace-contexts*))) |
---|
566 | (with-toplevel-commands :break |
---|
567 | (if *continuablep* |
---|
568 | (let* ((*print-circle* *error-print-circle*) |
---|
569 | (*print-level* *backtrace-print-level*) |
---|
570 | (*print-length* *backtrace-print-length*) |
---|
571 | ;(*print-pretty* nil) |
---|
572 | (*print-array* nil)) |
---|
573 | (format t "~&> Type :GO to continue, :POP to abort, :R for a list of available restarts.") |
---|
574 | (format t "~&> If continued: ~A~%" continue)) |
---|
575 | (format t "~&> Type :POP to abort, :R for a list of available restarts.~%")) |
---|
576 | (format t "~&> Type :? for other options.") |
---|
577 | (terpri) |
---|
578 | (force-output) |
---|
579 | |
---|
580 | (clear-input *debug-io*) |
---|
581 | (setq *error-reentry-count* 0) ; succesfully reported error |
---|
582 | (ignoring-without-interrupts |
---|
583 | (unwind-protect |
---|
584 | (progn |
---|
585 | (application-ui-operation *application* |
---|
586 | :enter-backtrace-context context) |
---|
587 | (read-loop :break-level (1+ *break-level*) |
---|
588 | :input-stream *debug-io* |
---|
589 | :output-stream *debug-io*)) |
---|
590 | (application-ui-operation *application* :exit-backtrace-context |
---|
591 | context))))))) |
---|
592 | |
---|
593 | |
---|
594 | |
---|
595 | (defun display-restarts (&optional (condition *break-condition*)) |
---|
596 | (let ((i 0)) |
---|
597 | (format t "~&[Pretend that these are buttons.]") |
---|
598 | (dolist (r (compute-restarts condition) i) |
---|
599 | (format t "~&~a : ~A" i r) |
---|
600 | (setq i (%i+ i 1))) |
---|
601 | (fresh-line nil))) |
---|
602 | |
---|
603 | (defun select-restart (n &optional (condition *break-condition*)) |
---|
604 | (let* ((restarts (compute-restarts condition))) |
---|
605 | (invoke-restart-interactively |
---|
606 | (nth (require-type n `(integer 0 (,(length restarts)))) restarts)))) |
---|
607 | |
---|
608 | |
---|
609 | |
---|
610 | |
---|
611 | ; End of l1-readloop-lds.lisp |
---|