src/code/warm-error.lisp

   1 ;;;; error stuff that needs to wait until warm 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 (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???
  21   (do-all-symbols (s)
  22     (unless (macro-function s)
  23       (let ((info (sb-int:info :function :type s)))
  24         (when (consp info)
  25           (let ((parsed (specifier-type info)))
  26             (setf (sb-int:info :function :type s) parsed)))))))
  27
  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
  36                                   arguments))
  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)
  41                                     super 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)
  47               (muffle-warning ()
  48                 :report "Skip warning."
  49                 (return-from %warn nil)))
  50             (format *error-output* "~&~@<~S: ~3i~:_~A~:>~%"
  51                     superclassoid-name condition)))
  52          nil))
  53
  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))
  66
  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))
  72
  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)))