1.0.21.14: fix CHECK-FASL-HEADER buglet
[sbcl.git] / src / code / defbangstruct.lisp
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. This is
8 ;;;;     important because at least as of sbcl-0.6.11.26, CLOS is built
9 ;;;;     (compiled) after cold init, so we need to have the compiler
10 ;;;;     even before CLOS runs.
11
12 ;;;; This software is part of the SBCL system. See the README file for
13 ;;;; more information.
14 ;;;;
15 ;;;; This software is derived from the CMU CL system, which was
16 ;;;; written at Carnegie Mellon University and released into the
17 ;;;; public domain. The software is in the public domain and is
18 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
19 ;;;; files for more information.
20
21 (in-package "SB!KERNEL")
22
23 ;;; A bootstrap MAKE-LOAD-FORM method can be a function or the name
24 ;;; of a function.
25 (deftype def!struct-type-make-load-form-fun () '(or function symbol))
26
27 ;;; a little single-inheritance system to keep track of MAKE-LOAD-FORM
28 ;;; information for DEF!STRUCT-defined types
29 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
30
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*)
36       (unless value-p
37         (error "~S is not a DEF!STRUCT-defined type." type))
38       value))
39   (defun (setf def!struct-supertype) (value type)
40     (when (and value #-sb-xc-host *type-system-initialized*)
41       (aver (subtypep value 'structure!object))
42       (aver (subtypep type value)))
43     (setf (gethash type *def!struct-supertype*) value))
44
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
51   ;; entry.
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))
55         (nil)
56       (multiple-value-bind (value value-p)
57           (gethash supertype *def!struct-type-make-load-form-fun*)
58         (unless value-p
59           (error "~S (supertype of ~S) is not a DEF!STRUCT-defined type."
60                  supertype
61                  type))
62         (when value
63           (return value))
64         (setf supertype (def!struct-supertype supertype))
65         (unless supertype
66           (error "There is no MAKE-LOAD-FORM function for bootstrap type ~S."
67                  type)))))
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       (aver (subtypep type 'structure!object))
71       (aver (typep new-value 'def!struct-type-make-load-form-fun)))
72     (setf (gethash type *def!struct-type-make-load-form-fun*) new-value)))
73
74 ;;; the simplest, most vanilla MAKE-LOAD-FORM function for DEF!STRUCT
75 ;;; objects
76 (defun just-dump-it-normally (object &optional (env nil env-p))
77   (declare (type structure!object object))
78   (declare (ignorable env env-p object))
79   ;; KLUDGE: we require essentially three different behaviours of
80   ;; JUST-DUMP-IT-NORMALLY, two of which (host compiler's
81   ;; MAKE-LOAD-FORM, cross-compiler's MAKE-LOAD-FORM) are handled by
82   ;; the #+SB-XC-HOST clause.  The #-SB-XC-HOST clause is the
83   ;; behaviour required by the target, before the CLOS-based
84   ;; MAKE-LOAD-FORM-SAVING-SLOTS is implemented.
85   #+sb-xc-host
86   (if env-p
87       (sb!xc:make-load-form-saving-slots object :environment env)
88       (sb!xc:make-load-form-saving-slots object))
89   #-sb-xc-host
90   :sb-just-dump-it-normally)
91
92 ;;; a MAKE-LOAD-FORM function for objects which don't use the load
93 ;;; form system. This is used for LAYOUT objects because the special
94 ;;; dumping requirements of LAYOUT objects are met by using special
95 ;;; VOPs which bypass the load form system. It's also used for various
96 ;;; compiler internal structures like nodes and VOP-INFO (FIXME:
97 ;;; Why?).
98 (defun ignore-it (object &optional env)
99   (declare (type structure!object object))
100   (declare (ignore object env))
101   ;; This magic tag is handled specially by the compiler downstream.
102   :ignore-it)
103
104 ;;; machinery used in the implementation of DEF!STRUCT
105 #+sb-xc-host
106 (eval-when (:compile-toplevel :load-toplevel :execute)
107   ;; a description of a DEF!STRUCT call to be stored until we get
108   ;; enough of the system running to finish processing it
109   (defstruct delayed-def!struct
110     (args (missing-arg) :type cons)
111     (package (sane-package) :type package))
112   ;; a list of DELAYED-DEF!STRUCTs stored until we get DEF!STRUCT
113   ;; working fully so that we can apply it to them then. After
114   ;; DEF!STRUCT is made to work fully, this list is processed, then
115   ;; made unbound, and should no longer be used.
116   (defvar *delayed-def!structs* nil))
117 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
118   ;; Parse the arguments for a DEF!STRUCT call, and return
119   ;;   (VALUES NAME DEFSTRUCT-ARGS MAKE-LOAD-FORM-FUN DEF!STRUCT-SUPERTYPE),
120   ;; where NAME is the name of the new type, DEFSTRUCT-ARGS is the
121   ;; munged result suitable for passing on to DEFSTRUCT,
122   ;; MAKE-LOAD-FORM-FUN is the make load form function, or NIL if
123   ;; there's none, and DEF!STRUCT-SUPERTYPE is the direct supertype of
124   ;; the type if it is another DEF!STRUCT-defined type, or NIL
125   ;; otherwise.
126   (defun parse-def!struct-args (nameoid &rest rest)
127     (multiple-value-bind (name options) ; Note: OPTIONS can change below.
128         (if (consp nameoid)
129             (values (first nameoid) (rest nameoid))
130             (values nameoid nil))
131       (declare (type list options))
132       (let* ((include-clause (find :include options :key #'first))
133              (def!struct-supertype nil) ; may change below
134              (mlff-clause (find :make-load-form-fun options :key #'first))
135              (mlff (and mlff-clause (second mlff-clause))))
136         (when (find :type options :key #'first)
137           (error "can't use :TYPE option in DEF!STRUCT"))
138         (when mlff-clause
139           (setf options (remove mlff-clause options)))
140         (when include-clause
141           (setf def!struct-supertype (second include-clause)))
142         (if (eq name 'structure!object) ; if root of hierarchy
143             (aver (not include-clause))
144             (unless include-clause
145               (setf def!struct-supertype 'structure!object)
146               (push `(:include ,def!struct-supertype) options)))
147         (values name `((,name ,@options) ,@rest) mlff def!struct-supertype)))))
148
149 ;;; Part of the raison d'etre for DEF!STRUCT is to be able to emulate
150 ;;; these low-level CMU CL functions in a vanilla ANSI Common Lisp
151 ;;; cross compilation host. (The emulation doesn't need to be
152 ;;; efficient, since it's needed for things like dumping objects, not
153 ;;; inner loops.)
154 #+sb-xc-host
155 (progn
156   (defun %instance-length (instance)
157     (aver (typep instance 'structure!object))
158     (layout-length (classoid-layout (find-classoid (type-of instance)))))
159   (defun %instance-ref (instance index)
160     (aver (typep instance 'structure!object))
161     (let* ((class (find-classoid (type-of instance)))
162            (layout (classoid-layout class)))
163       (if (zerop index)
164           layout
165           (let* ((dd (layout-info layout))
166                  (dsd (elt (dd-slots dd) (1- index)))
167                  (accessor-name (dsd-accessor-name dsd)))
168             (declare (type symbol accessor-name))
169             (funcall accessor-name instance)))))
170   (defun %instance-set (instance index new-value)
171     (aver (typep instance 'structure!object))
172     (let* ((class (find-classoid (type-of instance)))
173            (layout (classoid-layout class)))
174       (if (zerop index)
175           (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host")
176           (let* ((dd (layout-info layout))
177                  (dsd (elt (dd-slots dd) (1- index)))
178                  (accessor-name (dsd-accessor-name dsd)))
179             (declare (type symbol accessor-name))
180             (funcall (fdefinition `(setf ,accessor-name))
181                      new-value
182                      instance))))))
183
184 ;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return
185 ;;; DEFSTRUCT-style arguments with any class names in the SB!XC
186 ;;; package (i.e. the name of the class being defined, and/or the
187 ;;; names of classes in :INCLUDE clauses) converted from SB!XC::FOO to
188 ;;; CL::FOO.
189 #+sb-xc-host
190 (eval-when (:compile-toplevel :load-toplevel :execute)
191   (defun uncross-defstruct-args (defstruct-args)
192     (destructuring-bind (name-and-options &rest slots-and-doc) defstruct-args
193       (multiple-value-bind (name options)
194           (if (symbolp name-and-options)
195               (values name-and-options nil)
196               (values (first name-and-options)
197                       (rest name-and-options)))
198         (flet ((uncross-option (option)
199                  (if (eq (first option) :include)
200                      (destructuring-bind
201                          (include-keyword included-name &rest rest)
202                          option
203                        `(,include-keyword
204                          ,(uncross included-name)
205                          ,@rest))
206                    option)))
207           `((,(uncross name)
208              ,@(mapcar #'uncross-option options))
209             ,@slots-and-doc))))))
210
211 ;;; DEF!STRUCT's arguments are like DEFSTRUCT's arguments, except that
212 ;;; DEF!STRUCT accepts an extra optional :MAKE-LOAD-FORM-FUN clause.
213 ;;; DEF!STRUCT also does some magic to ensure that anything it defines
214 ;;; includes STRUCTURE!OBJECT, so that when CLOS is/becomes available,
215 ;;; we can hook the DEF!STRUCT system into
216 ;;;   (DEFMETHOD MAKE-LOAD-FORM ((X STRUCTURE!OBJECT) &OPTIONAL ENV) ..)
217 ;;; and everything will continue to work.
218 (defmacro def!struct (&rest args)
219   (multiple-value-bind (name defstruct-args mlff def!struct-supertype)
220       (apply #'parse-def!struct-args args)
221     `(progn
222        ;; There are two valid cases here: creating the
223        ;; STRUCTURE!OBJECT root of the inheritance hierarchy, or
224        ;; inheriting from STRUCTURE!OBJECT somehow.
225       ;;
226        ;; The invalid case that we want to exclude is when an :INCLUDE
227        ;; clause was used, and the included class didn't inherit frmo
228        ;; STRUCTURE!OBJECT. We want to catch that error ASAP because
229        ;; otherwise the bug might lurk until someone tried to do
230        ;; MAKE-LOAD-FORM on an instance of the class.
231        ,@(if (eq name 'structure!object)
232              (aver (null def!struct-supertype))
233              `((aver (subtypep ',def!struct-supertype 'structure!object))))
234        (defstruct ,@defstruct-args)
235        (setf (def!struct-type-make-load-form-fun ',name)
236              ,(if (symbolp mlff)
237                   `',mlff
238                   mlff)
239              (def!struct-supertype ',name)
240              ',def!struct-supertype)
241        #+sb-xc-host ,(let ((u (uncross-defstruct-args defstruct-args)))
242                        (if (boundp '*delayed-def!structs*)
243                            `(push (make-delayed-def!struct :args ',u)
244                                   *delayed-def!structs*)
245                            `(sb!xc:defstruct ,@u)))
246        ',name)))
247
248 ;;; When building the cross-compiler, this function has to be called
249 ;;; some time after SB!XC:DEFSTRUCT is set up, in order to take care
250 ;;; of any processing which had to be delayed until then.
251 #+sb-xc-host
252 (defun force-delayed-def!structs ()
253   (if (boundp '*delayed-def!structs*)
254       (progn
255         (mapcar (lambda (x)
256                   (let ((*package* (delayed-def!struct-package x)))
257                     ;; KLUDGE(?): EVAL is almost always the wrong thing.
258                     ;; However, since we have to map DEFSTRUCT over the
259                     ;; list, and since ANSI declined to specify any
260                     ;; functional primitives corresponding to the
261                     ;; DEFSTRUCT macro, it seems to me that EVAL is
262                     ;; required in there somewhere..
263                     (eval `(sb!xc:defstruct ,@(delayed-def!struct-args x)))))
264                 (reverse *delayed-def!structs*))
265         ;; We shouldn't need this list any more. Making it unbound
266         ;; serves as a signal to DEF!STRUCT that it needn't delay
267         ;; DEF!STRUCTs any more. It is also generally a good thing for
268         ;; other reasons: it frees garbage, and it discourages anyone
269         ;; else from pushing anything else onto the list later.
270         (makunbound '*delayed-def!structs*))
271       ;; This condition is probably harmless if it comes up when
272       ;; interactively experimenting with the system by loading a source
273       ;; file into it more than once. But it's worth warning about it
274       ;; because it definitely shouldn't come up in an ordinary build
275       ;; process.
276       (warn "*DELAYED-DEF!STRUCTS* is already unbound.")))
277
278 ;;; The STRUCTURE!OBJECT abstract class is the base of the type
279 ;;; hierarchy for objects which have/use DEF!STRUCT functionality.
280 ;;; (The extra hackery in DEF!STRUCT-defined things isn't needed for
281 ;;; STRUCTURE-OBJECTs defined by ordinary, post-warm-init programs, so
282 ;;; it's only put into STRUCTURE-OBJECTs which inherit from
283 ;;; STRUCTURE!OBJECT.)
284 (def!struct (structure!object (:constructor nil)))
285 \f
286 ;;;; hooking this all into the standard MAKE-LOAD-FORM system
287
288 ;;; MAKE-LOAD-FORM for DEF!STRUCT-defined types
289 (defun structure!object-make-load-form (object &optional env)
290   (declare (ignore env))
291   (funcall (def!struct-type-make-load-form-fun (type-of object))
292            object))
293
294 ;;; Do the right thing at cold load time.
295 ;;;
296 ;;; (Eventually this MAKE-LOAD-FORM function be overwritten by CLOS's
297 ;;; generic MAKE-LOAD-FORM, at which time a STRUCTURE!OBJECT method
298 ;;; should be added to call STRUCTURE!OBJECT-MAKE-LOAD-FORM.)
299 (setf (symbol-function 'sb!xc:make-load-form)
300       #'structure!object-make-load-form)
301
302 ;;; Do the right thing in the vanilla ANSI CLOS of the
303 ;;; cross-compilation host. (Something similar will have to be done in
304 ;;; our CLOS, too, but later, some time long after the toplevel forms
305 ;;; of this file have run.)
306 #+sb-xc-host
307 (defmethod make-load-form ((obj structure!object) &optional (env nil env-p))
308   (if env-p
309       (structure!object-make-load-form obj env)
310       (structure!object-make-load-form obj)))