;;;; 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))
(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 object))
+ ;; 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
;; 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))
;; 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))
- (assert (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)
+ ;; There are two valid cases here: creating the
+ ;; STRUCTURE!OBJECT root of the inheritance hierarchy, or
+ ;; inheriting from STRUCTURE!OBJECT somehow.
+ ;;
+ ;; The invalid case that we want to exclude is when an :INCLUDE
+ ;; clause was used, and the included class didn't inherit frmo
+ ;; STRUCTURE!OBJECT. We want to catch that error ASAP because
+ ;; otherwise the bug might lurk until someone tried to do
+ ;; MAKE-LOAD-FORM on an instance of the class.
+ ,@(if (eq name 'structure!object)
+ (aver (null def!struct-supertype))
+ `((aver (subtypep ',def!struct-supertype 'structure!object))))
- ;; This bit of commented-out code hasn't been needed for quite
- ;; some time, but the comments here about why not might still
- ;; be useful to me until I finally get the system to work. When
- ;; I do remove all this, I should be sure also to remove the
- ;; "outside the EVAL-WHEN" comments above, since they will no
- ;; longer make sense. -- WHN 19990803
- ;;(eval-when (:compile-toplevel :load-toplevel :execute)
- ;; ;; (The DEFSTRUCT used to be in here, but that failed when trying
- ;; ;; to cross-compile the hash table implementation.)
- ;; ;;(defstruct ,@defstruct-args)
- ;; ;; The (SETF (DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN ..) ..) used to
- ;; ;; be in here too, but that failed an assertion in the SETF
- ;; ;; definition once we moved the DEFSTRUCT outside.)
- ;; )
#+sb-xc-host ,(let ((u (uncross-defstruct-args defstruct-args)))
(if (boundp '*delayed-def!structs*)
`(push (make-delayed-def!struct :args ',u)
#+sb-xc-host ,(let ((u (uncross-defstruct-args defstruct-args)))
(if (boundp '*delayed-def!structs*)
`(push (make-delayed-def!struct :args ',u)
- (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.)