src/code/condition-boot.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!KERNEL")
  11
  12 (!defstruct-with-alternate-metaclass condition
  13   :slot-names (assigned-slots hash)
  14   ;; constructor is never called, but (FIXME) the macro syntax requires it
  15   :boa-constructor %make-condition-object
  16   :superclass-name t
  17   :metaclass-name condition-classoid
  18   :metaclass-constructor make-condition-classoid
  19   :dd-type structure)
  20
  21 ;;; Define just enough condition-classoids to get TYPEP
  22 ;;; to optimize into classoid-typep.
  23 (macrolet ((def (name direct-supers &rest inherits)
  24              `(eval-when (:compile-toplevel :execute)
  25                 ;; INHERITS is a list of symbols, unevaluated,
  26                 ;; excluding T which is assumed.
  27                 (%compiler-define-condition
  28                  ',name ',direct-supers
  29                  ,(make-layout
  30                    :classoid (make-undefined-classoid name)
  31                    :inherits (map 'vector #'find-layout (cons t inherits))
  32                    :depthoid -1
  33                    ;; 2 declared slots, plus the layout if it takes a slot
  34                    :length (+ sb!vm:instance-data-start 2))
  35                  nil nil))))
  36   ;; These are grotesquely OAOO-violating, but on the bright side,
  37   ;; compilation will fail if the subsequent real definition differs,
  38   ;; so there's a built-in safety net.
  39   ;; As has been suggested in 'cross-condition', a DEF!CONDITION macro
  40   ;; might help, but still that's possibly not a complete solution,
  41   ;; because DEBUG-CONDITION is defined in a file with the :NOT-HOST flag.
  42   (def simple-condition (condition) condition)
  43   (def warning (condition) condition)
  44   (def style-warning (warning) condition warning)
  45   (def compiler-note (condition) condition)
  46   (def parse-unknown-type (condition) condition)
  47   (def parse-deprecated-type (condition) condition)
  48   (def serious-condition (condition) condition)
  49   (def error (serious-condition) condition serious-condition)
  50   (def sb!di:debug-condition (serious-condition) condition serious-condition)
  51   (def stream-error (error) condition serious-condition error)
  52   (def reference-condition (condition) condition)
  53   )
  54
  55 ;;; Needed for !CALL-A-METHOD to pick out CONDITIONs
  56 (defun !condition-p (x) (typep x 'condition))