1 ;;;; DEF!STRUCT = bootstrap DEFSTRUCT, a wrapper around DEFSTRUCT which
2 ;;;; provides special features to help at bootstrap time:
3 ;;;; 1. Layout information, inheritance information, and so forth is
4 ;;;; retained in such a way that we can get to it even on vanilla
5 ;;;; ANSI Common Lisp at cross-compiler build time.
6 ;;;; 2. MAKE-LOAD-FORM information is stored in such a way that we can
7 ;;;; get to it at bootstrap time before CLOS is built.
9 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; more information.
12 ;;;; This software is derived from the CMU CL system, which was
13 ;;;; written at Carnegie Mellon University and released into the
14 ;;;; public domain. The software is in the public domain and is
15 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
16 ;;;; files for more information.
18 (in-package "SB!KERNEL")
20 ;;; A bootstrap MAKE-LOAD-FORM method can be a function or the name
22 (deftype def!struct-type-make-load-form-fun () '(or function symbol))
24 ;;; a little single-inheritance system to keep track of MAKE-LOAD-FORM
25 ;;; information for DEF!STRUCT-defined types
26 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
28 ;; FIXME: All this could be byte compiled. (Perhaps most of the rest
29 ;; of the file could be, too.)
31 ;; (DEF!STRUCT-SUPERTYPE TYPE) is the DEF!STRUCT-defined type that
32 ;; TYPE inherits from, or NIL if none.
33 (defvar *def!struct-supertype* (make-hash-table))
34 (defun def!struct-supertype (type)
35 (multiple-value-bind (value value-p) (gethash type *def!struct-supertype*)
37 (error "~S is not a DEF!STRUCT-defined type." type))
39 (defun (setf def!struct-supertype) (value type)
40 (when (and value #-sb-xc-host *type-system-initialized*)
41 (assert (subtypep value 'structure!object))
42 (assert (subtypep type value)))
43 (setf (gethash type *def!struct-supertype*) value))
45 ;; (DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN TYPE) is the load form
46 ;; generator associated with the DEF!STRUCT-defined structure named
47 ;; TYPE, stored in a way which works independently of CLOS. The
48 ;; *DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN* table is used to store the
49 ;; values. All types defined by DEF!STRUCT have an entry in the
50 ;; table; those with no MAKE-LOAD-FORM function have an explicit NIL
52 (defvar *def!struct-type-make-load-form-fun* (make-hash-table))
53 (defun def!struct-type-make-load-form-fun (type)
54 (do ((supertype type))
56 (multiple-value-bind (value value-p)
57 (gethash supertype *def!struct-type-make-load-form-fun*)
59 (error "~S (supertype of ~S) is not a DEF!STRUCT-defined type."
64 (setf supertype (def!struct-supertype supertype))
66 (error "There is no MAKE-LOAD-FORM function for bootstrap type ~S."
68 (defun (setf def!struct-type-make-load-form-fun) (new-value type)
69 (when #+sb-xc-host t #-sb-xc-host *type-system-initialized*
70 (assert (subtypep type 'structure!object))
71 (check-type new-value def!struct-type-make-load-form-fun))
72 (setf (gethash type *def!struct-type-make-load-form-fun*) new-value)))
74 ;;; the simplest, most vanilla MAKE-LOAD-FORM function for DEF!STRUCT
76 (defun just-dump-it-normally (object &optional (env nil env-p))
77 (declare (type structure!object object))
79 (make-load-form-saving-slots object :environment env)
80 (make-load-form-saving-slots object)))
82 ;;; a MAKE-LOAD-FORM function for objects which don't use the load
83 ;;; form system. This is used for LAYOUT objects because the special
84 ;;; dumping requirements of LAYOUT objects are met by using special
85 ;;; VOPs which bypass the load form system. It's also used for various
86 ;;; compiler internal structures like nodes and VOP-INFO (FIXME:
88 (defun ignore-it (object &optional env)
89 (declare (type structure!object object))
90 (declare (ignore object env))
91 ;; This magic tag is handled specially by the compiler downstream.
94 ;;; machinery used in the implementation of DEF!STRUCT
96 (eval-when (:compile-toplevel :load-toplevel :execute)
97 ;; a description of a DEF!STRUCT call to be stored until we get
98 ;; enough of the system running to finish processing it
99 (defstruct delayed-def!struct
100 (args (required-argument) :type cons)
101 (package (sane-package) :type package))
102 ;; a list of DELAYED-DEF!STRUCTs stored until we get DEF!STRUCT
103 ;; working fully so that we can apply it to them then. After
104 ;; DEF!STRUCT is made to work fully, this list is processed, then
105 ;; made unbound, and should no longer be used.
106 (defvar *delayed-def!structs* nil))
107 (eval-when (:compile-toplevel :load-toplevel :execute)
108 ;; Parse the arguments for a DEF!STRUCT call, and return
109 ;; (VALUES NAME DEFSTRUCT-ARGS MAKE-LOAD-FORM-FUN DEF!STRUCT-SUPERTYPE),
110 ;; where NAME is the name of the new type, DEFSTRUCT-ARGS is the
111 ;; munged result suitable for passing on to DEFSTRUCT,
112 ;; MAKE-LOAD-FORM-FUN is the make load form function, or NIL if
113 ;; there's none, and DEF!STRUCT-SUPERTYPE is the direct supertype of
114 ;; the type if it is another DEF!STRUCT-defined type, or NIL
116 (defun parse-def!struct-args (nameoid &rest rest)
117 (multiple-value-bind (name options) ; Note: OPTIONS can change below.
119 (values (first nameoid) (rest nameoid))
120 (values nameoid nil))
121 (let* ((include-clause (find :include options :key #'first))
122 (def!struct-supertype nil) ; may change below
123 (mlff-clause (find :make-load-form-fun options :key #'first))
124 (mlff (and mlff-clause (second mlff-clause))))
125 (when (find :type options :key #'first)
126 (error "can't use :TYPE option in DEF!STRUCT"))
128 (setf options (remove mlff-clause options)))
130 (setf def!struct-supertype (second include-clause)))
131 (if (eq name 'structure!object) ; if root of hierarchy
132 (assert (not include-clause))
133 (unless include-clause
134 (setf def!struct-supertype 'structure!object)
135 (push `(:include ,def!struct-supertype) options)))
136 (values name `((,name ,@options) ,@rest) mlff def!struct-supertype)))))
138 ;;; Part of the raison d'etre for DEF!STRUCT is to be able to emulate
139 ;;; these low-level CMU CL functions in a vanilla ANSI Common Lisp
140 ;;; cross compilation host. (The emulation doesn't need to be
141 ;;; efficient, since it's needed for things like dumping objects, not
145 (defun %instance-length (instance)
146 (check-type instance structure!object)
147 (layout-length (class-layout (sb!xc:find-class (type-of instance)))))
148 (defun %instance-ref (instance index)
149 (check-type instance structure!object)
150 (let* ((class (sb!xc:find-class (type-of instance)))
151 (layout (class-layout class)))
154 (let* ((dd (layout-info layout))
155 (dsd (elt (dd-slots dd) (1- index)))
156 (accessor (dsd-accessor dsd)))
157 (declare (type symbol accessor))
158 (funcall accessor instance)))))
159 (defun %instance-set (instance index new-value)
160 (check-type instance structure!object)
161 (let* ((class (sb!xc:find-class (type-of instance)))
162 (layout (class-layout class)))
164 (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host")
165 (let* ((dd (layout-info layout))
166 (dsd (elt (dd-slots dd) (1- index)))
167 (accessor (dsd-accessor dsd)))
168 (declare (type symbol accessor))
169 (funcall (fdefinition `(setf ,accessor)) new-value instance))))))
171 ;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return
172 ;;; DEFSTRUCT-style arguments with any class names in the SB!XC
173 ;;; package (i.e. the name of the class being defined, and/or the
174 ;;; names of classes in :INCLUDE clauses) converted from SB!XC::FOO to
177 (eval-when (:compile-toplevel :load-toplevel :execute)
178 (defun uncross-defstruct-args (defstruct-args)
179 (destructuring-bind (name-and-options &rest slots-and-doc) defstruct-args
180 (multiple-value-bind (name options)
181 (if (symbolp name-and-options)
182 (values name-and-options nil)
183 (values (first name-and-options)
184 (rest name-and-options)))
185 (flet ((uncross-option (option)
186 (if (eq (first option) :include)
188 (include-keyword included-name &rest rest)
191 ,(uncross included-name)
195 ,@(mapcar #'uncross-option options))
196 ,@slots-and-doc))))))
198 ;;; DEF!STRUCT's arguments are like DEFSTRUCT's arguments, except that
199 ;;; DEF!STRUCT accepts an extra optional :MAKE-LOAD-FORM-FUN clause.
200 ;;; DEF!STRUCT also does some magic to ensure that anything it defines
201 ;;; includes STRUCTURE!OBJECT, so that when CLOS is/becomes available,
202 ;;; we can hook the DEF!STRUCT system into
203 ;;; (DEFMETHOD MAKE-LOAD-FORM ((X STRUCTURE!OBJECT) &OPTIONAL ENV) ..)
204 ;;; and everything will continue to work.
205 (defmacro def!struct (&rest args)
206 (multiple-value-bind (name defstruct-args mlff def!struct-supertype)
207 (apply #'parse-def!struct-args args)
209 ;; (Putting the DEFSTRUCT here, outside the EVAL-WHEN, seems to
210 ;; be necessary in order to cross-compile the hash table
211 ;; implementation. -- WHN 19990809)
212 (defstruct ,@defstruct-args)
213 ;; (Putting this SETF here, outside the EVAL-WHEN, seems to be
214 ;; necessary in order to allow us to put the DEFSTRUCT outside
216 (setf (def!struct-type-make-load-form-fun ',name)
220 (def!struct-supertype ',name)
221 ',def!struct-supertype)
222 ;; This bit of commented-out code hasn't been needed for quite
223 ;; some time, but the comments here about why not might still
224 ;; be useful to me until I finally get the system to work. When
225 ;; I do remove all this, I should be sure also to remove the
226 ;; "outside the EVAL-WHEN" comments above, since they will no
227 ;; longer make sense. -- WHN 19990803
228 ;;(eval-when (:compile-toplevel :load-toplevel :execute)
229 ;; ;; (The DEFSTRUCT used to be in here, but that failed when trying
230 ;; ;; to cross-compile the hash table implementation.)
231 ;; ;;(defstruct ,@defstruct-args)
232 ;; ;; The (SETF (DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN ..) ..) used to
233 ;; ;; be in here too, but that failed an assertion in the SETF
234 ;; ;; definition once we moved the DEFSTRUCT outside.)
236 #+sb-xc-host ,(let ((u (uncross-defstruct-args defstruct-args)))
237 (if (boundp '*delayed-def!structs*)
238 `(push (make-delayed-def!struct :args ',u)
239 *delayed-def!structs*)
240 `(sb!xc:defstruct ,@u)))
243 ;;; When building the cross-compiler, this function has to be called
244 ;;; some time after SB!XC:DEFSTRUCT is set up, in order to take care
245 ;;; of any processing which had to be delayed until then.
247 (defun force-delayed-def!structs ()
248 (if (boundp '*delayed-def!structs*)
251 (let ((*package* (delayed-def!struct-package x)))
252 ;; KLUDGE(?): EVAL is almost always the wrong thing.
253 ;; However, since we have to map DEFSTRUCT over the
254 ;; list, and since ANSI declined to specify any
255 ;; functional primitives corresponding to the
256 ;; DEFSTRUCT macro, it seems to me that EVAL is
257 ;; required in there somewhere..
258 (eval `(sb!xc:defstruct ,@(delayed-def!struct-args x)))))
259 (reverse *delayed-def!structs*))
260 ;; We shouldn't need this list any more. Making it unbound
261 ;; serves as a signal to DEF!STRUCT that it needn't delay
262 ;; DEF!STRUCTs any more. It is also generally a good thing for
263 ;; other reasons: it frees garbage, and it discourages anyone
264 ;; else from pushing anything else onto the list later.
265 (makunbound '*delayed-def!structs*))
266 ;; This condition is probably harmless if it comes up when
267 ;; interactively experimenting with the system by loading a source
268 ;; file into it more than once. But it's worth warning about it
269 ;; because it definitely shouldn't come up in an ordinary build
271 (warn "*DELAYED-DEF!STRUCTS* is already unbound.")))
273 ;;; The STRUCTURE!OBJECT abstract class is the base of the type
274 ;;; hierarchy for objects which use DEF!STRUCT functionality.
275 (def!struct (structure!object (:constructor nil)))
277 ;;;; hooking this all into the standard MAKE-LOAD-FORM system
279 (defun structure!object-make-load-form (object &optional env)
281 "MAKE-LOAD-FORM for DEF!STRUCT-defined types"
282 (declare (ignore env))
283 (funcall (def!struct-type-make-load-form-fun (type-of object))
286 ;;; Do the right thing at cold load time.
288 ;;; (Eventually this MAKE-LOAD-FORM function be overwritten by CLOS's
289 ;;; generic MAKE-LOAD-FORM, at which time a STRUCTURE!OBJECT method
290 ;;; should be added to call STRUCTURE!OBJECT-MAKE-LOAD-FORM.)
291 (setf (symbol-function 'sb!xc:make-load-form)
292 #'structure!object-make-load-form)
294 ;;; Do the right thing in the vanilla ANSI CLOS of the
295 ;;; cross-compilation host. (Something similar will have to be done in
296 ;;; our CLOS, too, but later, some time long after the toplevel forms
297 ;;; of this file have run.)
299 (defmethod make-load-form ((obj structure!object) &optional (env nil env-p))
301 (structure!object-make-load-form obj env)
302 (structure!object-make-load-form obj)))