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 ;;; Moved from 'cold-error' to this file because of (at least) these reasons:
  15 ;;;  - the LOAD-TIME-VALUE forms need to run after 'condition.lisp'
  16 ;;;    has created the WARNING and STYLE-WARNING classoids
  17 ;;;  - even if this were loaded no earlier than the classoid definitions,
  18 ;;;    the entirety of condition handling doesn't work soon enough in cold-init.
  19 (flet ((%warn (datum super default-type &rest arguments)
  20          (infinite-error-protect
  21           (let ((condition (apply #'coerce-to-condition datum default-type 'warn
  22                                   arguments))
  23                 (superclassoid-name (classoid-name super)))
  24             ;; CONDITION is necessarily an INSTANCE,
  25             ;; but pedantry requires it be the right subtype of instance.
  26             (unless (classoid-typep (%instance-layout condition)
  27                                     super condition)
  28               (error 'simple-type-error
  29                      :datum datum :expected-type superclassoid-name
  30                      :format-control "~S does not designate a ~A class"
  31                      :format-arguments (list datum superclassoid-name)))
  32             (restart-case (%signal condition)
  33               (muffle-warning ()
  34                 :report "Skip warning."
  35                 (return-from %warn nil)))
  36             (format *error-output* "~&~@<~S: ~3i~:_~A~:>~%"
  37                     superclassoid-name condition)))
  38          nil))
  39
  40   ;; We don't warn about redefinition of WARN, apparently (not sure why)
  41   (defun warn (datum &rest arguments)
  42   "Warn about a situation by signalling a condition formed by DATUM and
  43    ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
  44    exists that causes WARN to immediately return NIL."
  45     (declare (explicit-check))
  46     ;; FIXME: figure out how to get genesis to understand that certain
  47     ;; classoids (particularly those defined by the language standard)
  48     ;; never need to go through the classoid-cell indirection,
  49     ;; as the classoid object itself is essentially permanent.
  50     (apply #'%warn datum (load-time-value (find-classoid 'warning) t)
  51            'simple-warning arguments))
  52
  53   ;; But we would warn about redefinition of STYLE-WARN.
  54   (fmakunbound 'style-warn)
  55
  56   (defun style-warn (datum &rest arguments)
  57     (declare (explicit-check))
  58     (apply #'%warn datum (load-time-value (find-classoid 'style-warning) t)
  59            'simple-style-warning arguments)))