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