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 (let ((condition (coerce-to-condition datum
29 (*handler-clusters* *handler-clusters*))
30 (let ((old-bos *break-on-signals*)
31 (*break-on-signals* nil))
32 (when (typep condition old-bos)
33 (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* (now NIL)."
36 (unless *handler-clusters* (return))
37 (let ((cluster (pop *handler-clusters*)))
38 (dolist (handler cluster)
39 (when (typep condition (car handler))
40 (funcall (cdr handler) condition)))))
43 ;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
44 ;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a
45 ;;; single argument that's directly usable by all the other routines.
46 (defun coerce-to-condition (datum arguments default-type fun-name)
47 (cond ((typep datum 'condition)
49 (cerror "Ignore the additional arguments."
53 :format-control "You may not supply additional arguments ~
54 when giving ~S to ~S."
55 :format-arguments (list datum fun-name)))
57 ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
58 (apply #'make-condition datum arguments))
59 ((or (stringp datum) (functionp datum))
60 (make-condition default-type
62 :format-arguments arguments))
64 (error 'simple-type-error
66 :expected-type '(or symbol string)
67 :format-control "bad argument to ~S: ~S"
68 :format-arguments (list fun-name datum)))))
70 ;;; a shared idiom in ERROR, CERROR, and BREAK: The user probably
71 ;;; doesn't want to hear that the error "occurred in" one of these
72 ;;; functions, so we try to point the top of the stack to our caller
74 (eval-when (:compile-toplevel :execute)
75 (defmacro-mundanely maybe-find-stack-top-hint ()
76 `(or sb!debug:*stack-top-hint*
77 (nth-value 1 (sb!kernel:find-caller-name-and-frame)))))
79 (defun error (datum &rest arguments)
81 "Invoke the signal facility on a condition formed from datum and arguments.
82 If the condition is not handled, the debugger is invoked."
83 (/show0 "entering ERROR, argument list=..")
85 (/show0 "printing ERROR arguments one by one..")
86 #!+sb-show (dolist (argument arguments)
87 (sb!impl::cold-print argument))
88 (sb!kernel:infinite-error-protect
89 (let ((condition (coerce-to-condition datum arguments
90 'simple-error 'error))
91 (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
92 (let ((sb!debug:*stack-top-hint* nil))
94 (invoke-debugger condition))))
96 (defun cerror (continue-string datum &rest arguments)
97 (sb!kernel:infinite-error-protect
99 (continue "~A" (apply #'format nil continue-string arguments))
100 (let ((condition (if (typep datum 'condition)
102 (coerce-to-condition datum
106 (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
107 (with-condition-restarts condition (list (find-restart 'continue))
108 (let ((sb!debug:*stack-top-hint* nil))
110 (invoke-debugger condition)))))
113 ;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
114 ;;; we can use it in system code (e.g. in SIGINT handling) without
115 ;;; messing up --noprogrammer mode (which works by setting
117 (defun %break (what &optional (datum "break") &rest arguments)
118 (sb!kernel:infinite-error-protect
119 (with-simple-restart (continue "Return from ~S." what)
120 (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
122 (coerce-to-condition datum arguments 'simple-condition what)))))
125 (defun break (&optional (datum "break") &rest arguments)
127 "Print a message and invoke the debugger without allowing any possibility
128 of condition handling occurring."
129 (let ((*debugger-hook* nil)) ; as specifically required by ANSI
130 (apply #'%break 'break datum arguments)))
132 (defun warn (datum &rest arguments)
134 "Warn about a situation by signalling a condition formed by DATUM and
135 ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
136 exists that causes WARN to immediately return NIL."
137 (/noshow0 "entering WARN")
138 ;; KLUDGE: The current cold load initialization logic causes several calls
139 ;; to WARN, so we need to be able to handle them without dying. (And calling
140 ;; FORMAT or even PRINC in cold load is a good way to die.) Of course, the
141 ;; ideal would be to clean up cold load so that it doesn't call WARN..
143 (if (not *cold-init-complete-p*)
145 (/show0 "ignoring WARN in cold init, arguments=..")
146 #!+sb-show (dolist (argument arguments)
147 (sb!impl::cold-print argument)))
148 (sb!kernel:infinite-error-protect
149 (let ((condition (coerce-to-condition datum arguments
150 'simple-warning 'warn)))
151 (enforce-type condition warning)
152 (restart-case (signal condition)
154 :report "Skip warning."
155 (return-from warn nil)))
156 (let ((badness (etypecase condition
157 (style-warning 'style-warning)
158 (warning 'warning))))
159 (format *error-output*
160 "~&~@<~S: ~3i~:_~A~:>~%"