0.pre7.74:
[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   (/noshow0 "entering SIGNAL")
26   (let ((condition (coerce-to-condition datum
27                                         arguments
28                                         'simple-condition
29                                         'signal))
30         (*handler-clusters* *handler-clusters*))
31     (let ((old-bos *break-on-signals*)
32           (*break-on-signals* nil))
33       (when (typep condition old-bos)
34         (/noshow0 "doing BREAK in because of *BREAK-ON-SIGNALS*")
35         (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* (now NIL)."
36                condition)))
37     (loop
38       (unless *handler-clusters*
39         (/noshow0 "leaving LOOP because of unbound *HANDLER-CLUSTERS*")
40         (return))
41       (let ((cluster (pop *handler-clusters*)))
42         (/noshow0 "got CLUSTER=..")
43         (/nohexstr cluster)
44         (dolist (handler cluster)
45           (/noshow0 "looking at HANDLER=..")
46           (/nohexstr handler)
47           (when (typep condition (car handler))
48             (funcall (cdr handler) condition)))))
49     
50     (/noshow0 "returning from SIGNAL")
51     nil))
52
53 ;;; a utility for SIGNAL, ERROR, CERROR, WARN, and INVOKE-DEBUGGER:
54 ;;; Parse the hairy argument conventions into a single argument that's
55 ;;; directly usable by all the other routines.
56 (defun coerce-to-condition (datum arguments default-type fun-name)
57   (cond ((typep datum 'condition)
58          (if arguments
59              (cerror "Ignore the additional arguments."
60                      'simple-type-error
61                      :datum arguments
62                      :expected-type 'null
63                      :format-control "You may not supply additional arguments ~
64                                      when giving ~S to ~S."
65                      :format-arguments (list datum fun-name)))
66          datum)
67         ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
68          (apply #'make-condition datum arguments))
69         ((or (stringp datum) (functionp datum))
70          (make-condition default-type
71                          :format-control datum
72                          :format-arguments arguments))
73         (t
74          (error 'simple-type-error
75                 :datum datum
76                 :expected-type '(or symbol string)
77                 :format-control "bad argument to ~S: ~S"
78                 :format-arguments (list fun-name datum)))))
79
80 ;;; a shared idiom in ERROR, CERROR, and BREAK: The user probably
81 ;;; doesn't want to hear that the error "occurred in" one of these
82 ;;; functions, so we try to point the top of the stack to our caller
83 ;;; instead.
84 (eval-when (:compile-toplevel :execute)
85   (defmacro-mundanely maybe-find-stack-top-hint ()
86     `(or sb!debug:*stack-top-hint*
87          (nth-value 1 (sb!kernel:find-caller-name-and-frame)))))
88
89 (defun error (datum &rest arguments)
90   #!+sb-doc
91   "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
92   If the condition is not handled, the debugger is invoked."
93   (/show0 "entering ERROR, argument list=..")
94   (/hexstr arguments)
95
96   (/show0 "cold-printing ERROR arguments one by one..")
97   #!+sb-show (dolist (argument arguments)
98                (sb!impl::cold-print argument))
99   (/show0 "done cold-printing ERROR arguments")
100
101   (sb!kernel:infinite-error-protect
102     (let ((condition (coerce-to-condition datum arguments
103                                           'simple-error 'error))
104           (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
105       (/show0 "done coercing DATUM to CONDITION")
106       (let ((sb!debug:*stack-top-hint* nil))
107         (/show0 "signalling CONDITION from within ERROR")
108         (signal condition))
109       (/show0 "done signalling CONDITION within ERROR")
110       (invoke-debugger condition))))
111
112 (defun cerror (continue-string datum &rest arguments)
113   (sb!kernel:infinite-error-protect
114     (with-simple-restart
115         (continue "~A" (apply #'format nil continue-string arguments))
116       (let ((condition (if (typep datum 'condition)
117                            datum
118                            (coerce-to-condition datum
119                                                 arguments
120                                                 'simple-error
121                                                 'error)))
122             (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
123         (with-condition-restarts condition (list (find-restart 'continue))
124           (let ((sb!debug:*stack-top-hint* nil))
125             (signal condition))
126           (invoke-debugger condition)))))
127   nil)
128
129 ;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
130 ;;; we can use it in system code (e.g. in SIGINT handling) without
131 ;;; messing up --noprogrammer mode (which works by setting
132 ;;; *DEBUGGER-HOOK*); or for that matter, without messing up ordinary
133 ;;; applications which try to do similar things with *DEBUGGER-HOOK*
134 (defun %break (what &optional (datum "break") &rest arguments)
135   (sb!kernel:infinite-error-protect
136     (with-simple-restart (continue "Return from ~S." what)
137       (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
138         (invoke-debugger
139          (coerce-to-condition datum arguments 'simple-condition what)))))
140   nil)
141
142 (defun break (&optional (datum "break") &rest arguments)
143   #!+sb-doc
144   "Print a message and invoke the debugger without allowing any possibility
145    of condition handling occurring."
146   (let ((*debugger-hook* nil)) ; as specifically required by ANSI
147     (apply #'%break 'break datum arguments)))
148             
149 (defun warn (datum &rest arguments)
150   #!+sb-doc
151   "Warn about a situation by signalling a condition formed by DATUM and
152    ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
153    exists that causes WARN to immediately return NIL."
154   (/show0 "entering WARN")
155   ;; KLUDGE: The current cold load initialization logic causes several calls
156   ;; to WARN, so we need to be able to handle them without dying. (And calling
157   ;; FORMAT or even PRINC in cold load is a good way to die.) Of course, the
158   ;; ideal would be to clean up cold load so that it doesn't call WARN..
159   ;; -- WHN 19991009
160   (if (not *cold-init-complete-p*)
161       (progn
162         (/show0 "ignoring WARN in cold init, arguments=..")
163         #!+sb-show (dolist (argument arguments)
164                      (sb!impl::cold-print argument)))
165       (sb!kernel:infinite-error-protect
166        (/show0 "doing COERCE-TO-CONDITION")
167        (let ((condition (coerce-to-condition datum arguments
168                                              'simple-warning 'warn)))
169          (/show0 "back from COERCE-TO-CONDITION, doing ENFORCE-TYPE")
170          (enforce-type condition warning)
171          (/show0 "back from ENFORCE-TYPE, doing RESTART-CASE MUFFLE-WARNING")
172          (restart-case (signal condition)
173            (muffle-warning ()
174              :report "Skip warning."
175              (return-from warn nil)))
176          (/show0 "back from RESTART-CASE MUFFLE-WARNING (i.e. normal return)")
177
178          (let ((badness (etypecase condition
179                           (style-warning 'style-warning)
180                           (warning 'warning))))
181            (/show0 "got BADNESS, calling FORMAT")
182            (format *error-output*
183                    "~&~@<~S: ~3i~:_~A~:>~%"
184                    badness
185                    condition)
186            (/show0 "back from FORMAT, voila!")))))
187   nil)