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