1 ;;;; miscellaneous error stuff that needs to be in the cold load
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!KERNEL")
14 (defvar *break-on-signals* nil
16 "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will
17 enter the debugger prior to signalling that condition.")
19 (defun signal (datum &rest arguments)
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
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 rebound to NIL)."
38 (unless *handler-clusters*
39 (/noshow0 "leaving LOOP because of unbound *HANDLER-CLUSTERS*")
41 (let ((cluster (pop *handler-clusters*)))
42 (/noshow0 "got CLUSTER=..")
44 (dolist (handler cluster)
45 (/noshow0 "looking at HANDLER=..")
47 (when (typep condition (car handler))
48 (funcall (cdr handler) condition)))))
50 (/noshow0 "returning from SIGNAL")
53 ;;; a shared idiom in ERROR, CERROR, and BREAK: The user probably
54 ;;; doesn't want to hear that the error "occurred in" one of these
55 ;;; functions, so we try to point the top of the stack to our caller
57 (eval-when (:compile-toplevel :execute)
58 (defmacro-mundanely maybe-find-stack-top-hint ()
59 `(or sb!debug:*stack-top-hint*
60 (nth-value 1 (find-caller-name-and-frame)))))
62 (defun error (datum &rest arguments)
64 "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
65 If the condition is not handled, the debugger is invoked."
66 (/show0 "entering ERROR, argument list=..")
69 (/show0 "cold-printing ERROR arguments one by one..")
70 #!+sb-show (dolist (argument arguments)
71 (sb!impl::cold-print argument))
72 (/show0 "done cold-printing ERROR arguments")
74 (infinite-error-protect
75 (let ((condition (coerce-to-condition datum arguments
76 'simple-error 'error))
77 (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
78 (/show0 "done coercing DATUM to CONDITION")
79 (let ((sb!debug:*stack-top-hint* nil))
80 (/show0 "signalling CONDITION from within ERROR")
82 (/show0 "done signalling CONDITION within ERROR")
83 (invoke-debugger condition))))
85 (defun cerror (continue-string datum &rest arguments)
86 (infinite-error-protect
88 (continue "~A" (apply #'format nil continue-string arguments))
89 (let ((condition (coerce-to-condition datum
93 (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
94 (with-condition-restarts condition (list (find-restart 'continue))
95 (let ((sb!debug:*stack-top-hint* nil))
97 (invoke-debugger condition)))))
100 ;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
101 ;;; we can use it in system code (e.g. in SIGINT handling) without
102 ;;; messing up --disable-debugger mode (which works by setting
103 ;;; *DEBUGGER-HOOK*); or for that matter, without messing up ordinary
104 ;;; applications which try to do similar things with *DEBUGGER-HOOK*
105 (defun %break (what &optional (datum "break") &rest arguments)
106 (infinite-error-protect
107 (with-simple-restart (continue "Return from ~S." what)
108 (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
110 (coerce-to-condition datum arguments 'simple-condition what)))))
113 (defun break (&optional (datum "break") &rest arguments)
115 "Print a message and invoke the debugger without allowing any possibility
116 of condition handling occurring."
117 (let ((*debugger-hook* nil)) ; as specifically required by ANSI
118 (apply #'%break 'break datum arguments)))
120 (defun warn (datum &rest arguments)
122 "Warn about a situation by signalling a condition formed by DATUM and
123 ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
124 exists that causes WARN to immediately return NIL."
125 (/show0 "entering WARN")
126 ;; KLUDGE: The current cold load initialization logic causes several calls
127 ;; to WARN, so we need to be able to handle them without dying. (And calling
128 ;; FORMAT or even PRINC in cold load is a good way to die.) Of course, the
129 ;; ideal would be to clean up cold load so that it doesn't call WARN..
131 (if (not *cold-init-complete-p*)
133 (/show0 "ignoring WARN in cold init, arguments=..")
134 #!+sb-show (dolist (argument arguments)
135 (sb!impl::cold-print argument)))
136 (infinite-error-protect
137 (/show0 "doing COERCE-TO-CONDITION")
138 (let ((condition (coerce-to-condition datum arguments
139 'simple-warning 'warn)))
140 (/show0 "back from COERCE-TO-CONDITION, doing ENFORCE-TYPE")
141 (enforce-type condition warning)
142 (/show0 "back from ENFORCE-TYPE, doing RESTART-CASE MUFFLE-WARNING")
143 (restart-case (signal condition)
145 :report "Skip warning."
146 (return-from warn nil)))
147 (/show0 "back from RESTART-CASE MUFFLE-WARNING (i.e. normal return)")
149 (let ((badness (etypecase condition
150 (style-warning 'style-warning)
151 (warning 'warning))))
152 (/show0 "got BADNESS, calling FORMAT")
153 (format *error-output*
154 "~&~@<~S: ~3i~:_~A~:>~%"
157 (/show0 "back from FORMAT, voila!")))))