src/code/early-class.lisp

   1 ;;;; Early support routines for class-related things (including conditions).
   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 (defun call-with-defining-class (kind name thunk)
  15   (declare (ignorable kind name))
  16   (with-single-package-locked-error
  17       (:symbol name "defining ~S as a ~(~A~)" kind)
  18     (funcall thunk)))
  19
  20 (defun preinform-compiler-about-class-type (name forthcoming-info)
  21   ;; Unless the type system already has an actual type attached to
  22   ;; NAME (in which case (1) writing a placeholder value over that
  23   ;; actual type as a compile-time side-effect would probably be a bad
  24   ;; idea and (2) anyway we don't need to modify it in order to make
  25   ;; NAME be recognized as a valid type name)
  26   (when (and forthcoming-info (not (info :type :kind name)))
  27     ;; Tell the compiler to expect a class with the given NAME, by
  28     ;; writing a kind of minimal placeholder type information. This
  29     ;; placeholder will be overwritten later when the class is
  30     ;; defined.
  31     (setf (info :type :kind name) :forthcoming-defclass-type)))
  32
  33 (symbol-macrolet
  34     ((reader-function-type (specifier-type '(function (t) t)))
  35      (writer-function-type (specifier-type '(function (t t) t))))
  36   (flet ((proclaim-ftype-for-name (kind name type)
  37            (ecase kind
  38              (condition
  39               (sb!xc:proclaim `(ftype ,(type-specifier type) ,name)))
  40              (class
  41               (when (eq (info :function :where-from name) :assumed)
  42                 (sb!c:proclaim-ftype name type nil :defined))))))
  43
  44     (defun preinform-compiler-about-accessors (kind readers writers)
  45       (flet ((inform (names type)
  46                (mapc (lambda (name) (proclaim-ftype-for-name kind name type))
  47                      names)))
  48         (inform readers reader-function-type)
  49         (inform writers writer-function-type)))
  50
  51     (defun preinform-compiler-about-slot-functions (kind slots)
  52       (flet ((inform (slots key type)
  53                (mapc (lambda (slot)
  54                        (let ((name (funcall key slot)))
  55                          (proclaim-ftype-for-name kind name type)))
  56                      slots)))
  57         (inform slots #'sb!pcl::slot-reader-name reader-function-type)
  58         (inform slots #'sb!pcl::slot-boundp-name reader-function-type)
  59         (inform slots #'sb!pcl::slot-writer-name writer-function-type)))))
  60
  61 (defun %%compiler-defclass (name readers writers slots)
  62   ;; ANSI says (Macro DEFCLASS, section 7.7) that DEFCLASS, if it
  63   ;; "appears as a top level form, the compiler must make the class
  64   ;; name be recognized as a valid type name in subsequent
  65   ;; declarations (as for deftype) and be recognized as a valid class
  66   ;; name for defmethod parameter specializers and for use as the
  67   ;; :metaclass option of a subsequent defclass."
  68   (preinform-compiler-about-class-type name t)
  69   (preinform-compiler-about-accessors 'class readers writers)
  70   (preinform-compiler-about-slot-functions 'class slots))
  71
  72 (defun %compiler-defclass (name readers writers slots)
  73   (call-with-defining-class
  74    'class name
  75    (lambda ()
  76      (%%compiler-defclass name readers writers slots))))
  77
  78 ;;; This used to be in an (EVAL-WHEN (:COMPILE-TOPLEVEL ...))
  79 ;;; which no longer works, because at run-the-xc-time the
  80 ;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR macro doesn't work yet,
  81 ;;; so just use the definition that was loaded from the fasl
  82 ;;; when the cross-compiler was compiled.
  83 (defun %%compiler-define-condition (name direct-supers layout readers writers)
  84   (declare (notinline find-classoid))
  85   (preinform-compiler-about-class-type name nil)
  86   (preinform-compiler-about-accessors 'condition readers writers)
  87   (multiple-value-bind (class old-layout)
  88       (insured-find-classoid name
  89                              #'condition-classoid-p
  90                              #'make-condition-classoid)
  91     (setf (layout-classoid layout) class)
  92     (setf (classoid-direct-superclasses class)
  93           (mapcar #'find-classoid direct-supers))
  94     (cond ((not old-layout)
  95            (register-layout layout))
  96           ((not *type-system-initialized*)
  97            (setf (layout-classoid old-layout) class)
  98            (setq layout old-layout)
  99            (unless (eq (classoid-layout class) layout)
 100              (register-layout layout)))
 101           ((redefine-layout-warning "current"
 102                                     old-layout
 103                                     "new"
 104                                     (layout-length layout)
 105                                     (layout-inherits layout)
 106                                     (layout-depthoid layout)
 107                                     (layout-bitmap layout))
 108            (register-layout layout :invalidate t))
 109           ((not (classoid-layout class))
 110            (register-layout layout)))
 111
 112     ;; This looks totally bogus - it essentially means that the LAYOUT-INFO
 113     ;; of a condition is good for nothing, because it describes something
 114     ;; that is not the condition class being defined.
 115     ;; In addition to which, the INFO for CONDITION itself describes
 116     ;; slots which do not exist, viz:
 117     ;;  (dd-slots (layout-info (classoid-layout (find-classoid 'condition))))
 118     ;; => (#<DEFSTRUCT-SLOT-DESCRIPTION ACTUAL-INITARGS>
 119     ;;     #<DEFSTRUCT-SLOT-DESCRIPTION ASSIGNED-SLOTS>)
 120     (setf (layout-info layout)
 121           (layout-info (classoid-layout (find-classoid 'condition))))
 122
 123     (setf (find-classoid name) class)
 124
 125     ;; Initialize CPL slot.
 126     (setf (condition-classoid-cpl class)
 127           (remove-if-not #'condition-classoid-p
 128                          (std-compute-class-precedence-list class)))))
 129
 130 (defun %compiler-define-condition (name direct-supers layout readers writers)
 131   (call-with-defining-class
 132    'condition name
 133    (lambda ()
 134      (%%compiler-define-condition name direct-supers layout readers writers))))