;;; 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
(if env-p
(sb!xc:make-load-form-saving-slots object :environment env)
- (sb!xc:make-load-form-saving-slots object)))
+ (sb!xc:make-load-form-saving-slots object))
+ #-sb-xc-host
+ :sb-just-dump-it-normally)
;;; a MAKE-LOAD-FORM function for objects which don't use the load
;;; form system. This is used for LAYOUT objects because the special
;; 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))
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
;; 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
(if (consp nameoid)
(values (first nameoid) (rest nameoid))
(values nameoid nil))
+ (declare (type list options))
(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))
(progn
(defun %instance-length (instance)
(aver (typep instance 'structure!object))
- (layout-length (class-layout (sb!xc:find-class (type-of instance)))))
+ (layout-length (classoid-layout (find-classoid (type-of instance)))))
(defun %instance-ref (instance index)
(aver (typep instance 'structure!object))
- (let* ((class (sb!xc:find-class (type-of instance)))
- (layout (class-layout class)))
+ (let* ((class (find-classoid (type-of instance)))
+ (layout (classoid-layout class)))
(if (zerop index)
layout
(let* ((dd (layout-info layout))
(funcall accessor-name instance)))))
(defun %instance-set (instance index new-value)
(aver (typep instance 'structure!object))
- (let* ((class (sb!xc:find-class (type-of instance)))
- (layout (class-layout class)))
+ (let* ((class (find-classoid (type-of instance)))
+ (layout (classoid-layout class)))
(if (zerop index)
(error "can't set %INSTANCE-REF FOO 0 in cross-compilation host")
(let* ((dd (layout-info layout))
(multiple-value-bind (name defstruct-args mlff def!struct-supertype)
(apply #'parse-def!struct-args args)
`(progn
- ;; 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))
+ ;; 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))))
(defstruct ,@defstruct-args)
(setf (def!struct-type-make-load-form-fun ',name)
,(if (symbolp mlff)
mlff)
(def!struct-supertype ',name)
',def!struct-supertype)
- ;; 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)
projects / sbcl.git / blobdiff