src/code/early-condition.lisp

   1 ;;;; Just %COMPILER-DEFINE-CONDITION, moved out of 'condition'
   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 ;;; This used to be in an (EVAL-WHEN (:COMPILE-TOPLEVEL ...))
  15 ;;; which no longer works, because at run-the-xc-time the
  16 ;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR macro doesn't work yet,
  17 ;;; so just use the definition that was loaded from the fasl
  18 ;;; when the cross-compiler was compiled.
  19 (defun %compiler-define-condition (name direct-supers layout
  20                                         all-readers all-writers)
  21   (declare (notinline find-classoid))
  22   (with-single-package-locked-error
  23       (:symbol name "defining ~A as a condition")
  24     (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers))
  25     (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers))
  26     (multiple-value-bind (class old-layout)
  27         (insured-find-classoid name
  28                                #'condition-classoid-p
  29                                #'make-condition-classoid)
  30       (setf (layout-classoid layout) class)
  31       (setf (classoid-direct-superclasses class)
  32             (mapcar #'find-classoid direct-supers))
  33       (cond ((not old-layout)
  34              (register-layout layout))
  35             ((not *type-system-initialized*)
  36              (setf (layout-classoid old-layout) class)
  37              (setq layout old-layout)
  38              (unless (eq (classoid-layout class) layout)
  39                (register-layout layout)))
  40             ((redefine-layout-warning "current"
  41                                       old-layout
  42                                       "new"
  43                                       (layout-length layout)
  44                                       (layout-inherits layout)
  45                                       (layout-depthoid layout)
  46                                       (layout-raw-slot-metadata layout))
  47              (register-layout layout :invalidate t))
  48             ((not (classoid-layout class))
  49              (register-layout layout)))
  50
  51       ;; This looks totally bogus - it essentially means that the LAYOUT-INFO
  52       ;; of a condition is good for nothing, because it describes something
  53       ;; that is not the condition class being defined.
  54       ;; In addition to which, the INFO for CONDITION itself describes
  55       ;; slots which do not exist, viz:
  56       ;;  (dd-slots (layout-info (classoid-layout (find-classoid 'condition))))
  57       ;; => (#<DEFSTRUCT-SLOT-DESCRIPTION ACTUAL-INITARGS>
  58       ;;     #<DEFSTRUCT-SLOT-DESCRIPTION ASSIGNED-SLOTS>)
  59       (setf (layout-info layout)
  60             (layout-info (classoid-layout (find-classoid 'condition))))
  61
  62       (setf (find-classoid name) class)
  63
  64       ;; Initialize CPL slot.
  65       (setf (condition-classoid-cpl class)
  66             (remove-if-not #'condition-classoid-p
  67                            (std-compute-class-precedence-list class)))))
  68   (values))