source: trunk/source/level-1/l1-readloop-lds.lisp @ 14376

Last change on this file since 14376 was 14367, checked in by gb, 9 years ago

Add NTH-FUNCTION-FRAME, which is like NTH-RAW-FRAME but only counts
stack frames that are FUNCTION-FRAME-P. (There's little or no difference
on x86; on PPC and ARM, the multiple-value return mechanism creates some
extra stack frames.)

Toplevel break loop commands that take a frame number use NTH-FUNCTION-FRAME,
so the frame numbers correspond to the numbers that backtrace prints. (They
always did on x86, seldom did on PPC/ARM.)

Lose the :set toplevel command, which used raw frame numbers and raw value
indices (neither of which we display in any other break loop commands.)

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