X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefbangstruct.lisp;h=32d21351147f1ce2a0030ba2b247250af08eb80b;hb=54da325f13fb41669869aea688ae195426c0e231;hp=7b9ba18776eee2825101945d44d6a2b408aaf773;hpb=22b819c0cd0ca0ea5be52ba280b9e9e0b8e86210;p=sbcl.git diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index 7b9ba18..32d2135 100644 --- a/src/code/defbangstruct.lisp +++ b/src/code/defbangstruct.lisp @@ -34,7 +34,7 @@ (defun def!struct-supertype (type) (multiple-value-bind (value value-p) (gethash type *def!struct-supertype*) (unless value-p - (error "~S is not a DEF!STRUCT-defined type." type)) + (error "~S is not a DEF!STRUCT-defined type." type)) value)) (defun (setf def!struct-supertype) (value type) (when (and value #-sb-xc-host *type-system-initialized*) @@ -52,19 +52,19 @@ (defvar *def!struct-type-make-load-form-fun* (make-hash-table)) (defun def!struct-type-make-load-form-fun (type) (do ((supertype type)) - (nil) + (nil) (multiple-value-bind (value value-p) - (gethash supertype *def!struct-type-make-load-form-fun*) - (unless value-p - (error "~S (supertype of ~S) is not a DEF!STRUCT-defined type." - supertype - type)) - (when value - (return value)) - (setf supertype (def!struct-supertype supertype)) - (unless supertype - (error "There is no MAKE-LOAD-FORM function for bootstrap type ~S." - type))))) + (gethash supertype *def!struct-type-make-load-form-fun*) + (unless value-p + (error "~S (supertype of ~S) is not a DEF!STRUCT-defined type." + supertype + type)) + (when value + (return value)) + (setf supertype (def!struct-supertype supertype)) + (unless supertype + (error "There is no MAKE-LOAD-FORM function for bootstrap type ~S." + type))))) (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)) @@ -75,9 +75,19 @@ ;;; 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 @@ -115,26 +125,26 @@ ;; otherwise. (defun parse-def!struct-args (nameoid &rest rest) (multiple-value-bind (name options) ; Note: OPTIONS can change below. - (if (consp nameoid) - (values (first nameoid) (rest nameoid)) - (values nameoid nil)) + (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)) - (mlff (and mlff-clause (second mlff-clause)))) - (when (find :type options :key #'first) - (error "can't use :TYPE option in DEF!STRUCT")) - (when mlff-clause - (setf options (remove mlff-clause options))) - (when include-clause - (setf def!struct-supertype (second include-clause))) - (if (eq name 'structure!object) ; if root of hierarchy - (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))))) + (def!struct-supertype nil) ; may change below + (mlff-clause (find :make-load-form-fun options :key #'first)) + (mlff (and mlff-clause (second mlff-clause)))) + (when (find :type options :key #'first) + (error "can't use :TYPE option in DEF!STRUCT")) + (when mlff-clause + (setf options (remove mlff-clause options))) + (when include-clause + (setf def!struct-supertype (second include-clause))) + (if (eq name 'structure!object) ; if root of hierarchy + (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 ;;; these low-level CMU CL functions in a vanilla ANSI Common Lisp @@ -149,27 +159,27 @@ (defun %instance-ref (instance index) (aver (typep instance 'structure!object)) (let* ((class (find-classoid (type-of instance))) - (layout (classoid-layout class))) + (layout (classoid-layout class))) (if (zerop index) - 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))))) + 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))))) (defun %instance-set (instance index new-value) (aver (typep instance 'structure!object)) (let* ((class (find-classoid (type-of instance))) - (layout (classoid-layout class))) + (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-name (dsd-accessor-name dsd))) - (declare (type symbol accessor-name)) - (funcall (fdefinition `(setf ,accessor-name)) - 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)))))) ;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return ;;; DEFSTRUCT-style arguments with any class names in the SB!XC @@ -181,22 +191,22 @@ (defun uncross-defstruct-args (defstruct-args) (destructuring-bind (name-and-options &rest slots-and-doc) defstruct-args (multiple-value-bind (name options) - (if (symbolp name-and-options) - (values name-and-options nil) - (values (first name-and-options) - (rest name-and-options))) - (flet ((uncross-option (option) - (if (eq (first option) :include) - (destructuring-bind - (include-keyword included-name &rest rest) - option - `(,include-keyword - ,(uncross included-name) - ,@rest)) - option))) - `((,(uncross name) - ,@(mapcar #'uncross-option options)) - ,@slots-and-doc)))))) + (if (symbolp name-and-options) + (values name-and-options nil) + (values (first name-and-options) + (rest name-and-options))) + (flet ((uncross-option (option) + (if (eq (first option) :include) + (destructuring-bind + (include-keyword included-name &rest rest) + option + `(,include-keyword + ,(uncross included-name) + ,@rest)) + option))) + `((,(uncross name) + ,@(mapcar #'uncross-option options)) + ,@slots-and-doc)))))) ;;; DEF!STRUCT's arguments are like DEFSTRUCT's arguments, except that ;;; DEF!STRUCT accepts an extra optional :MAKE-LOAD-FORM-FUN clause. @@ -209,38 +219,30 @@ (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 - 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.) - ;; ) + ,(if (symbolp mlff) + `',mlff + mlff) + (def!struct-supertype ',name) + ',def!struct-supertype) #+sb-xc-host ,(let ((u (uncross-defstruct-args defstruct-args))) - (if (boundp '*delayed-def!structs*) - `(push (make-delayed-def!struct :args ',u) - *delayed-def!structs*) - `(sb!xc:defstruct ,@u))) + (if (boundp '*delayed-def!structs*) + `(push (make-delayed-def!struct :args ',u) + *delayed-def!structs*) + `(sb!xc:defstruct ,@u))) ',name))) ;;; When building the cross-compiler, this function has to be called @@ -250,22 +252,22 @@ (defun force-delayed-def!structs () (if (boundp '*delayed-def!structs*) (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*)) + (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 @@ -287,7 +289,7 @@ (defun structure!object-make-load-form (object &optional env) (declare (ignore env)) (funcall (def!struct-type-make-load-form-fun (type-of object)) - object)) + object)) ;;; Do the right thing at cold load time. ;;;