1 ;;;; error stuff that needs to wait until warm 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 (eval-when (:compile-toplevel
)
15 ;; Any globaldb value that references either the type named CLASS or CONDITION-CLASS
16 ;; would have been stored as its specifier instead of the parse of the specifier.
17 ;; Parse them now because "reasons" which will store unknown types, but is preferable
18 ;; to the alternative of warning each time we compile a function (such as WARN)
19 ;; that needs to know what the unknown type is, and tries to re-parse.
20 ;; Also, there are some unknowns in there already. How on earth did that happen???
22 (unless (macro-function s
)
23 (let ((info (sb-int:info
:function
:type s
)))
25 (let ((parsed (specifier-type info
)))
26 (setf (sb-int:info
:function
:type s
) parsed
)))))))
28 ;;; Moved from 'cold-error' to this file because of (at least) these reasons:
29 ;;; - the LOAD-TIME-VALUE forms need to run after 'condition.lisp'
30 ;;; has created the WARNING and STYLE-WARNING classoids
31 ;;; - even if this were loaded no earlier than the classoid definitions,
32 ;;; the entirety of condition handling doesn't work soon enough in cold-init.
33 (flet ((%warn
(datum super default-type
&rest arguments
)
34 (infinite-error-protect
35 (let ((condition (apply #'coerce-to-condition datum default-type
'warn
37 (superclassoid-name (classoid-name super
)))
38 ;; CONDITION is necessarily an INSTANCE,
39 ;; but pedantry requires it be the right subtype of instance.
40 (unless (classoid-typep (%instance-layout condition
)
42 (error 'simple-type-error
43 :datum datum
:expected-type superclassoid-name
44 :format-control
"~S does not designate a ~A class"
45 :format-arguments
(list datum superclassoid-name
)))
46 (restart-case (%signal condition
)
48 :report
"Skip warning."
49 (return-from %warn nil
)))
50 (format *error-output
* "~&~@<~S: ~3i~:_~A~:>~%"
51 superclassoid-name condition
)))
54 ;; We don't warn about redefinition of WARN, apparently (not sure why)
55 (defun warn (datum &rest arguments
)
56 "Warn about a situation by signalling a condition formed by DATUM and
57 ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
58 exists that causes WARN to immediately return NIL."
59 (declare (explicit-check))
60 ;; FIXME: figure out how to get genesis to understand that certain
61 ;; classoids (particularly those defined by the language standard)
62 ;; never need to go through the classoid-cell indirection,
63 ;; as the classoid object itself is essentially permanent.
64 (apply #'%warn datum
(load-time-value (find-classoid 'warning
) t
)
65 'simple-warning arguments
))
67 ;; But we would warn about redefinition of STYLE-WARN.
68 ;; Do a "gentle" fmakunbound, because real FMAKUNBOUND removes
69 ;; sb-c:fun-info thus blowing out the control string transformer.
70 #+linkage-space
(fset 'style-warn
0)
71 #-linkage-space
(fdefn-makunbound (find-fdefn 'style-warn
))
73 (defun style-warn (datum &rest arguments
)
74 (declare (explicit-check))
75 (apply #'%warn datum
(load-time-value (find-classoid 'style-warning
) t
)
76 'simple-style-warning arguments
)))