Silence notes about being specialised EQ templates on x86oids
[sbcl.git] / src / code / cold-error.lisp
1 ;;;; miscellaneous error stuff that needs to be in the cold load
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!KERNEL")
13
14 (defvar *break-on-signals* nil
15   #!+sb-doc
16   "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will
17    enter the debugger prior to signalling that condition.")
18
19 (defun maybe-break-on-signal (condition)
20   (let ((old-bos *break-on-signals*)
21         (bos-actually-breaking nil))
22     (restart-case
23         (let ((break-on-signals *break-on-signals*)
24               (*break-on-signals* nil))
25           ;; The rebinding encloses the TYPEP so that a bogus
26           ;; type specifier will not lead to infinite recursion when
27           ;; TYPEP fails.
28           (when (typep condition break-on-signals)
29             (setf bos-actually-breaking t)
30             (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~
31                     (now rebound to NIL)."
32                    condition)))
33       ;; Give the user a chance to unset *BREAK-ON-SIGNALS* on the
34       ;; way out.
35       ;;
36       ;; (e.g.: Consider a long compilation. After a failed compile
37       ;; the user sets *BREAK-ON-SIGNALS* to T, and select the
38       ;; RECOMPILE restart. Once the user diagnoses and fixes the
39       ;; problem, he selects RECOMPILE again... and discovers that
40       ;; he's entered the *BREAK-ON-SIGNALS* hell with no escape,
41       ;; unless we provide this restart.)
42       (reassign (new-value)
43         :report
44         (lambda (stream)
45           (format stream
46                   (if bos-actually-breaking
47                       "Return from BREAK and assign a new value to ~
48                        *BREAK-ON-SIGNALS*."
49                       "Assign a new value to *BREAK-ON-SIGNALS* and ~
50                        continue with signal handling.")))
51         :interactive
52         (lambda ()
53           (let (new-value)
54             (loop
55               (format *query-io*
56                       "Enter new value for *BREAK-ON-SIGNALS*. ~
57                        Current value is ~S.~%~
58                        > "
59                       old-bos)
60               (force-output *query-io*)
61               (let ((*break-on-signals* nil))
62                 (setf new-value (eval (read *query-io*)))
63                 (if (typep new-value 'type-specifier)
64                     (return)
65                     (format *query-io*
66                             "~S is not a valid value for *BREAK-ON-SIGNALS* ~
67                              (must be a type-specifier).~%"
68                             new-value))))
69             (list new-value)))
70         (setf *break-on-signals* new-value)))))
71
72 (defun signal (datum &rest arguments)
73   #!+sb-doc
74   "Invokes the signal facility on a condition formed from DATUM and
75    ARGUMENTS. If the condition is not handled, NIL is returned. If
76    (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
77    before any signalling is done."
78   (let ((condition (coerce-to-condition datum
79                                         arguments
80                                         'simple-condition
81                                         'signal))
82         (*handler-clusters* *handler-clusters*)
83         (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'signal)))
84     (when *break-on-signals*
85       (maybe-break-on-signal condition))
86     (loop
87       (unless *handler-clusters*
88         (return))
89       (let ((cluster (pop *handler-clusters*)))
90         (dolist (handler cluster)
91           (when (typep condition (car handler))
92             (funcall (cdr handler) condition)))))
93     nil))
94
95 (defun error (datum &rest arguments)
96   #!+sb-doc
97   "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
98   If the condition is not handled, the debugger is invoked."
99   (/show0 "entering ERROR, argument list=..")
100   (/hexstr arguments)
101
102   (/show0 "cold-printing ERROR arguments one by one..")
103   #!+sb-show (dolist (argument arguments)
104                (sb!impl::cold-print argument))
105   (/show0 "done cold-printing ERROR arguments")
106
107   (infinite-error-protect
108     (let ((condition (coerce-to-condition datum arguments
109                                           'simple-error 'error))
110           (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'error)))
111       (/show0 "done coercing DATUM to CONDITION")
112       (/show0 "signalling CONDITION from within ERROR")
113       (signal condition)
114       (/show0 "done signalling CONDITION within ERROR")
115       (invoke-debugger condition))))
116
117 (defun cerror (continue-string datum &rest arguments)
118   (infinite-error-protect
119     (with-simple-restart
120         (continue "~A" (apply #'format nil continue-string arguments))
121       (let ((condition (coerce-to-condition datum
122                                             arguments
123                                             'simple-error
124                                             'cerror)))
125         (with-condition-restarts condition (list (find-restart 'continue))
126           (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'cerror)))
127             (signal condition)
128             (invoke-debugger condition))))))
129   nil)
130
131 ;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
132 ;;; we can use it in system code (e.g. in SIGINT handling) without
133 ;;; messing up --disable-debugger mode (which works by setting
134 ;;; *DEBUGGER-HOOK*); or for that matter, without messing up ordinary
135 ;;; applications which try to do similar things with *DEBUGGER-HOOK*
136 (defun %break (what &optional (datum "break") &rest arguments)
137   (infinite-error-protect
138     (with-simple-restart (continue "Return from ~S." what)
139       (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* '%break)))
140         (invoke-debugger
141          (coerce-to-condition datum arguments 'simple-condition what)))))
142   nil)
143
144 (defun break (&optional (datum "break") &rest arguments)
145   #!+sb-doc
146   "Print a message and invoke the debugger without allowing any possibility
147 of condition handling occurring."
148   (let ((*debugger-hook* nil) ; as specifically required by ANSI
149         (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'break)))
150     (apply #'%break 'break datum arguments)))
151
152 (defun warn (datum &rest arguments)
153   #!+sb-doc
154   "Warn about a situation by signalling a condition formed by DATUM and
155    ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
156    exists that causes WARN to immediately return NIL."
157   (/show0 "entering WARN")
158   ;; KLUDGE: The current cold load initialization logic causes several calls
159   ;; to WARN, so we need to be able to handle them without dying. (And calling
160   ;; FORMAT or even PRINC in cold load is a good way to die.) Of course, the
161   ;; ideal would be to clean up cold load so that it doesn't call WARN..
162   ;; -- WHN 19991009
163   (if (not *cold-init-complete-p*)
164       (progn
165         (/show0 "ignoring WARN in cold init, arguments=..")
166         #!+sb-show (dolist (argument arguments)
167                      (sb!impl::cold-print argument)))
168       (infinite-error-protect
169        (/show0 "doing COERCE-TO-CONDITION")
170        (let ((condition (coerce-to-condition datum arguments
171                                              'simple-warning 'warn)))
172          (/show0 "back from COERCE-TO-CONDITION, doing ENFORCE-TYPE")
173          (enforce-type condition warning)
174          (/show0 "back from ENFORCE-TYPE, doing RESTART-CASE MUFFLE-WARNING")
175          (restart-case (signal condition)
176            (muffle-warning ()
177              :report "Skip warning."
178              (return-from warn nil)))
179          (/show0 "back from RESTART-CASE MUFFLE-WARNING (i.e. normal return)")
180
181          (let ((badness (etypecase condition
182                           (style-warning 'style-warning)
183                           (warning 'warning))))
184            (/show0 "got BADNESS, calling FORMAT")
185            (format *error-output*
186                    "~&~@<~S: ~3i~:_~A~:>~%"
187                    badness
188                    condition)
189            (/show0 "back from FORMAT, voila!")))))
190   nil)