X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefbangstruct.lisp;h=3e5c3a6981748db3180717201d217cf4b1f273eb;hb=8d490a4d6b9d7f156cf503826b3e3195e6f3ad39;hp=fecf0f8cd90d62fafe10c769b8d0fdb6a2d847f2;hpb=0b3ec4b1d978b887db175b7b3bada8e727683e15;p=sbcl.git diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index fecf0f8..3e5c3a6 100644 --- a/src/code/defbangstruct.lisp +++ b/src/code/defbangstruct.lisp @@ -28,9 +28,6 @@ ;;; information for DEF!STRUCT-defined types (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) - ;; FIXME: All this could be byte compiled. (Perhaps most of the rest - ;; of the file could be, too.) - ;; (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)) @@ -71,16 +68,26 @@ (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)) - (check-type new-value def!struct-type-make-load-form-fun)) + (aver (typep new-value 'def!struct-type-make-load-form-fun))) (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 (if env-p - (make-load-form-saving-slots object :environment env) - (make-load-form-saving-slots object))) + (sb!xc:make-load-form-saving-slots object :environment env) + (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 @@ -100,14 +107,14 @@ ;; 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 - (args (required-argument) :type cons) + (args (missing-arg) :type cons) (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)) -(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 @@ -121,6 +128,7 @@ (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)) @@ -146,30 +154,32 @@ #+sb-xc-host (progn (defun %instance-length (instance) - (check-type instance structure!object) - (layout-length (class-layout (sb!xc:find-class (type-of instance))))) + (aver (typep instance 'structure!object)) + (layout-length (classoid-layout (find-classoid (type-of instance))))) (defun %instance-ref (instance index) - (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))) (if (zerop index) layout (let* ((dd (layout-info layout)) (dsd (elt (dd-slots dd) (1- index))) - (accessor (dsd-accessor dsd))) - (declare (type symbol accessor)) - (funcall accessor instance))))) + (accessor-name (dsd-accessor-name dsd))) + (declare (type symbol accessor-name)) + (funcall accessor-name instance))))) (defun %instance-set (instance index new-value) - (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))) (if (zerop index) (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)))))) + (accessor-name (dsd-accessor-name dsd))) + (declare (type symbol accessor-name)) + (funcall (fdefinition `(setf ,accessor-name)) + new-value + instance)))))) ;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return ;;; DEFSTRUCT-style arguments with any class names in the SB!XC @@ -209,12 +219,18 @@ (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) @@ -222,20 +238,6 @@ 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)