1 ;;;; miscellaneous stuff that needs to be in the cold load which would
2 ;;;; otherwise be byte-compiled
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!CONDITIONS")
18 (defvar *break-on-signals* nil
20 "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will
21 enter the debugger prior to signalling that condition.")
23 (defun signal (datum &rest arguments)
25 "Invokes the signal facility on a condition formed from DATUM and
26 ARGUMENTS. If the condition is not handled, NIL is returned. If
27 (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
28 before any signalling is done."
29 (let ((condition (coerce-to-condition datum
33 (*handler-clusters* *handler-clusters*))
34 (let ((old-bos *break-on-signals*)
35 (*break-on-signals* nil))
36 (when (typep condition old-bos)
37 (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* (now NIL)."
40 (unless *handler-clusters* (return))
41 (let ((cluster (pop *handler-clusters*)))
42 (dolist (handler cluster)
43 (when (typep condition (car handler))
44 (funcall (cdr handler) condition)))))
47 ;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
48 ;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single
49 ;;; argument that's directly usable by all the other routines.
50 (defun coerce-to-condition (datum arguments default-type function-name)
51 (cond ((typep datum 'condition)
53 (cerror "Ignore the additional arguments."
57 :format-control "You may not supply additional arguments ~
58 when giving ~S to ~S."
59 :format-arguments (list datum function-name)))
61 ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
62 (apply #'make-condition datum arguments))
63 ((or (stringp datum) (functionp datum))
64 (make-condition default-type
66 :format-arguments arguments))
68 (error 'simple-type-error
70 :expected-type '(or symbol string)
71 :format-control "bad argument to ~S: ~S"
72 :format-arguments (list function-name datum)))))
74 (defun error (datum &rest arguments)
76 "Invoke the signal facility on a condition formed from datum and arguments.
77 If the condition is not handled, the debugger is invoked."
78 (/show0 "entering ERROR")
80 (unless *cold-init-complete-p*
81 (/show0 "ERROR in cold init, arguments=..")
82 #!+sb-show (dolist (argument arguments)
83 (sb!impl::cold-print argument)))
84 (sb!kernel:infinite-error-protect
85 (let ((condition (coerce-to-condition datum arguments
86 'simple-error 'error))
87 ;; FIXME: Why is *STACK-TOP-HINT* in SB-DEBUG instead of SB-DI?
88 ;; SB-DEBUG should probably be only for true interface stuff.
89 (sb!debug:*stack-top-hint* sb!debug:*stack-top-hint*))
90 (unless (and (condition-function-name condition)
91 sb!debug:*stack-top-hint*)
92 (multiple-value-bind (name frame) (sb!kernel:find-caller-name)
93 (unless (condition-function-name condition)
94 (setf (condition-function-name condition) name))
95 (unless sb!debug:*stack-top-hint*
96 (setf sb!debug:*stack-top-hint* frame))))
97 (let ((sb!debug:*stack-top-hint* nil))
99 (invoke-debugger condition))))
101 (defun cerror (continue-string datum &rest arguments)
102 (sb!kernel:infinite-error-protect
104 (continue "~A" (apply #'format nil continue-string arguments))
105 (let ((condition (if (typep datum 'condition)
107 (coerce-to-condition datum
111 (sb!debug:*stack-top-hint* sb!debug:*stack-top-hint*))
112 (unless (and (condition-function-name condition)
113 sb!debug:*stack-top-hint*)
114 (multiple-value-bind (name frame) (sb!kernel:find-caller-name)
115 (unless (condition-function-name condition)
116 (setf (condition-function-name condition) name))
117 (unless sb!debug:*stack-top-hint*
118 (setf sb!debug:*stack-top-hint* frame))))
119 (with-condition-restarts condition (list (find-restart 'continue))
120 (let ((sb!debug:*stack-top-hint* nil))
122 (invoke-debugger condition)))))
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 (sb!kernel:infinite-error-protect
130 (with-simple-restart (continue "Return from BREAK.")
131 (let ((sb!debug:*stack-top-hint*
132 (or sb!debug:*stack-top-hint*
133 (nth-value 1 (sb!kernel:find-caller-name)))))
135 (coerce-to-condition datum arguments 'simple-condition 'break)))))
138 (defun warn (datum &rest arguments)
140 "Warn about a situation by signalling a condition formed by DATUM and
141 ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
142 exists that causes WARN to immediately return NIL."
143 (/noshow0 "entering WARN")
144 ;; KLUDGE: The current cold load initialization logic causes several calls
145 ;; to WARN, so we need to be able to handle them without dying. (And calling
146 ;; FORMAT or even PRINC in cold load is a good way to die.) Of course, the
147 ;; ideal would be to clean up cold load so that it doesn't call WARN..
149 (if (not *cold-init-complete-p*)
151 (/show0 "ignoring WARN in cold init, arguments=..")
152 #!+sb-show (dolist (argument arguments)
153 (sb!impl::cold-print argument)))
154 (sb!kernel:infinite-error-protect
155 (let ((condition (coerce-to-condition datum arguments
156 'simple-warning 'warn)))
157 (check-type condition warning "a warning condition")
158 (restart-case (signal condition)
160 :report "Skip warning."
161 (return-from warn nil)))
162 (let ((badness (etypecase condition
163 (style-warning 'style-warning)
164 (warning 'warning))))
165 (format *error-output*
166 "~&~@<~S: ~3i~:_~A~:>~%"