;;;; retained in such a way that we can get to it even on vanilla
;;;; ANSI Common Lisp at cross-compiler build time.
;;;; 2. MAKE-LOAD-FORM information is stored in such a way that we can
;;;; retained in such a way that we can get to it even on vanilla
;;;; ANSI Common Lisp at cross-compiler build time.
;;;; 2. MAKE-LOAD-FORM information is stored in such a way that we can
-;;;; get to it at bootstrap time before CLOS is built.
+;;;; get to it at bootstrap time before CLOS is built. This is
+;;;; important because at least as of sbcl-0.6.11.26, CLOS is built
+;;;; (compiled) after cold init, so we need to have the compiler
+;;;; even before CLOS runs.
;; (DEF!STRUCT-SUPERTYPE TYPE) is the DEF!STRUCT-defined type that
;; TYPE inherits from, or NIL if none.
(defvar *def!struct-supertype* (make-hash-table))
;; (DEF!STRUCT-SUPERTYPE TYPE) is the DEF!STRUCT-defined type that
;; TYPE inherits from, or NIL if none.
(defvar *def!struct-supertype* (make-hash-table))
(defun (setf def!struct-type-make-load-form-fun) (new-value type)
(when #+sb-xc-host t #-sb-xc-host *type-system-initialized*
(aver (subtypep type 'structure!object))
(defun (setf def!struct-type-make-load-form-fun) (new-value type)
(when #+sb-xc-host t #-sb-xc-host *type-system-initialized*
(aver (subtypep type 'structure!object))
(setf (gethash type *def!struct-type-make-load-form-fun*) new-value)))
;;; the simplest, most vanilla MAKE-LOAD-FORM function for DEF!STRUCT
;;; objects
(defun just-dump-it-normally (object &optional (env nil env-p))
(declare (type structure!object object))
(setf (gethash type *def!struct-type-make-load-form-fun*) new-value)))
;;; the simplest, most vanilla MAKE-LOAD-FORM function for DEF!STRUCT
;;; objects
(defun just-dump-it-normally (object &optional (env nil env-p))
(declare (type structure!object object))
+ (declare (ignorable env env-p))
+ ;; KLUDGE: we require essentially three different behaviours of
+ ;; JUST-DUMP-IT-NORMALLY, two of which (host compiler's
+ ;; MAKE-LOAD-FORM, cross-compiler's MAKE-LOAD-FORM) are handled by
+ ;; the #+SB-XC-HOST clause. The #-SB-XC-HOST clause is the
+ ;; behaviour required by the target, before the CLOS-based
+ ;; MAKE-LOAD-FORM-SAVING-SLOTS is implemented.
+ #+sb-xc-host
;; a description of a DEF!STRUCT call to be stored until we get
;; enough of the system running to finish processing it
(defstruct delayed-def!struct
;; a description of a DEF!STRUCT call to be stored until we get
;; enough of the system running to finish processing it
(defstruct delayed-def!struct
(package (sane-package) :type package))
;; a list of DELAYED-DEF!STRUCTs stored until we get DEF!STRUCT
;; working fully so that we can apply it to them then. After
;; DEF!STRUCT is made to work fully, this list is processed, then
;; made unbound, and should no longer be used.
(defvar *delayed-def!structs* nil))
(package (sane-package) :type package))
;; a list of DELAYED-DEF!STRUCTs stored until we get DEF!STRUCT
;; working fully so that we can apply it to them then. After
;; DEF!STRUCT is made to work fully, this list is processed, then
;; made unbound, and should no longer be used.
(defvar *delayed-def!structs* nil))
;; Parse the arguments for a DEF!STRUCT call, and return
;; (VALUES NAME DEFSTRUCT-ARGS MAKE-LOAD-FORM-FUN DEF!STRUCT-SUPERTYPE),
;; where NAME is the name of the new type, DEFSTRUCT-ARGS is the
;; Parse the arguments for a DEF!STRUCT call, and return
;; (VALUES NAME DEFSTRUCT-ARGS MAKE-LOAD-FORM-FUN DEF!STRUCT-SUPERTYPE),
;; where NAME is the name of the new type, DEFSTRUCT-ARGS is the
(let* ((include-clause (find :include options :key #'first))
(def!struct-supertype nil) ; may change below
(mlff-clause (find :make-load-form-fun options :key #'first))
(let* ((include-clause (find :include options :key #'first))
(def!struct-supertype nil) ; may change below
(mlff-clause (find :make-load-form-fun options :key #'first))
- (aver (not include-clause))
- (unless include-clause
- (setf def!struct-supertype 'structure!object)
- (push `(:include ,def!struct-supertype) options)))
+ (aver (not include-clause))
+ (unless include-clause
+ (setf def!struct-supertype 'structure!object)
+ (push `(:include ,def!struct-supertype) options)))
(values name `((,name ,@options) ,@rest) mlff def!struct-supertype)))))
;;; Part of the raison d'etre for DEF!STRUCT is to be able to emulate
(values name `((,name ,@options) ,@rest) mlff def!struct-supertype)))))
;;; Part of the raison d'etre for DEF!STRUCT is to be able to emulate
- (check-type instance structure!object)
- (let* ((class (sb!xc:find-class (type-of instance)))
- (layout (class-layout class)))
+ (aver (typep instance 'structure!object))
+ (let* ((class (find-classoid (type-of instance)))
+ (layout (classoid-layout class)))
- layout
- (let* ((dd (layout-info layout))
- (dsd (elt (dd-slots dd) (1- index)))
- (accessor (dsd-accessor dsd)))
- (declare (type symbol accessor))
- (funcall accessor instance)))))
+ layout
+ (let* ((dd (layout-info layout))
+ (dsd (elt (dd-slots dd) (1- index)))
+ (accessor-name (dsd-accessor-name dsd)))
+ (declare (type symbol accessor-name))
+ (funcall accessor-name instance)))))
- (check-type instance structure!object)
- (let* ((class (sb!xc:find-class (type-of instance)))
- (layout (class-layout class)))
+ (aver (typep instance 'structure!object))
+ (let* ((class (find-classoid (type-of instance)))
+ (layout (classoid-layout class)))
- (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host")
- (let* ((dd (layout-info layout))
- (dsd (elt (dd-slots dd) (1- index)))
- (accessor (dsd-accessor dsd)))
- (declare (type symbol accessor))
- (funcall (fdefinition `(setf ,accessor)) new-value instance))))))
+ (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host")
+ (let* ((dd (layout-info layout))
+ (dsd (elt (dd-slots dd) (1- index)))
+ (accessor-name (dsd-accessor-name dsd)))
+ (declare (type symbol accessor-name))
+ (funcall (fdefinition `(setf ,accessor-name))
+ new-value
+ instance))))))
(destructuring-bind (name-and-options &rest slots-and-doc) defstruct-args
(multiple-value-bind (name options)
(if (symbolp name-and-options)
(destructuring-bind (name-and-options &rest slots-and-doc) defstruct-args
(multiple-value-bind (name options)
(if (symbolp name-and-options)
- ;; (Putting the DEFSTRUCT here, outside the EVAL-WHEN, seems to
- ;; be necessary in order to cross-compile the hash table
- ;; implementation. -- WHN 19990809)
+ ;; Make sure that we really do include STRUCTURE!OBJECT. (If an
+ ;; :INCLUDE clause was used, and the included class didn't
+ ;; itself include STRUCTURE!OBJECT, then we wouldn't; and it's
+ ;; better to find out ASAP then to let the bug lurk until
+ ;; someone tries to do MAKE-LOAD-FORM on the object.)
+ (aver (subtypep ',def!struct-supertype 'structure!object))
- (progn
- (mapcar (lambda (x)
- (let ((*package* (delayed-def!struct-package x)))
- ;; KLUDGE(?): EVAL is almost always the wrong thing.
- ;; However, since we have to map DEFSTRUCT over the
- ;; list, and since ANSI declined to specify any
- ;; functional primitives corresponding to the
- ;; DEFSTRUCT macro, it seems to me that EVAL is
- ;; required in there somewhere..
- (eval `(sb!xc:defstruct ,@(delayed-def!struct-args x)))))
- (reverse *delayed-def!structs*))
- ;; We shouldn't need this list any more. Making it unbound
- ;; serves as a signal to DEF!STRUCT that it needn't delay
- ;; DEF!STRUCTs any more. It is also generally a good thing for
- ;; other reasons: it frees garbage, and it discourages anyone
- ;; else from pushing anything else onto the list later.
- (makunbound '*delayed-def!structs*))
- ;; This condition is probably harmless if it comes up when
- ;; interactively experimenting with the system by loading a source
- ;; file into it more than once. But it's worth warning about it
- ;; because it definitely shouldn't come up in an ordinary build
- ;; process.
- (warn "*DELAYED-DEF!STRUCTS* is already unbound.")))
+ (progn
+ (mapcar (lambda (x)
+ (let ((*package* (delayed-def!struct-package x)))
+ ;; KLUDGE(?): EVAL is almost always the wrong thing.
+ ;; However, since we have to map DEFSTRUCT over the
+ ;; list, and since ANSI declined to specify any
+ ;; functional primitives corresponding to the
+ ;; DEFSTRUCT macro, it seems to me that EVAL is
+ ;; required in there somewhere..
+ (eval `(sb!xc:defstruct ,@(delayed-def!struct-args x)))))
+ (reverse *delayed-def!structs*))
+ ;; We shouldn't need this list any more. Making it unbound
+ ;; serves as a signal to DEF!STRUCT that it needn't delay
+ ;; DEF!STRUCTs any more. It is also generally a good thing for
+ ;; other reasons: it frees garbage, and it discourages anyone
+ ;; else from pushing anything else onto the list later.
+ (makunbound '*delayed-def!structs*))
+ ;; This condition is probably harmless if it comes up when
+ ;; interactively experimenting with the system by loading a source
+ ;; file into it more than once. But it's worth warning about it
+ ;; because it definitely shouldn't come up in an ordinary build
+ ;; process.
+ (warn "*DELAYED-DEF!STRUCTS* is already unbound.")))
-;;; hierarchy for objects which use DEF!STRUCT functionality.
+;;; hierarchy for objects which have/use DEF!STRUCT functionality.
+;;; (The extra hackery in DEF!STRUCT-defined things isn't needed for
+;;; STRUCTURE-OBJECTs defined by ordinary, post-warm-init programs, so
+;;; it's only put into STRUCTURE-OBJECTs which inherit from
+;;; STRUCTURE!OBJECT.)