1 ;;;; Early support routines for class-related things (including conditions).
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!KERNEL")
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
)
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
31 (setf (info :type
:kind name
) :forthcoming-defclass-type
)))
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
)
39 (sb!xc
:proclaim
`(ftype ,(type-specifier type
) ,name
)))
41 (when (eq (info :function
:where-from name
) :assumed
)
42 (sb!c
:proclaim-ftype name type nil
:defined
))))))
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
))
48 (inform readers reader-function-type
)
49 (inform writers writer-function-type
)))
51 (defun preinform-compiler-about-slot-functions (kind slots
)
52 (flet ((inform (slots key type
)
54 (let ((name (funcall key slot
)))
55 (proclaim-ftype-for-name kind name type
)))
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
)))))
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
))
72 (defun %compiler-defclass
(name readers writers slots
)
73 (call-with-defining-class
76 (%%compiler-defclass name readers writers slots
))))
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"
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
)))
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
))))
123 (setf (find-classoid name
) class
)
125 ;; Initialize CPL slot.
126 (setf (condition-classoid-cpl class
)
127 (remove-if-not #'condition-classoid-p
128 (std-compute-class-precedence-list class
)))))
130 (defun %compiler-define-condition
(name direct-supers layout readers writers
)
131 (call-with-defining-class
134 (%%compiler-define-condition name direct-supers layout readers writers
))))