X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefbangstruct.lisp;h=9ba54be6497b875c121da44e5d3129c83d492c46;hb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;hp=cd705549b26269aea259df7650ebc2c1e3c1feb2;hpb=334af30b26555f0bf706f7157b399bdbd4fad548;p=sbcl.git diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index cd70554..9ba54be 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)) + ;; 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 @@ -119,8 +126,9 @@ (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)) + (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)) @@ -132,10 +140,10 @@ (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))) + (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 @@ -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))))) + 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) - (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)))))) + (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 @@ -182,17 +192,17 @@ (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))) + (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)) + (destructuring-bind + (include-keyword included-name &rest rest) + option + `(,include-keyword + ,(uncross included-name) + ,@rest)) option))) `((,(uncross name) ,@(mapcar #'uncross-option options)) @@ -209,17 +219,17 @@ (multiple-value-bind (name defstruct-args mlff def!struct-supertype) (apply #'parse-def!struct-args args) `(progn - ;; (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)) (defstruct ,@defstruct-args) - ;; (Putting this SETF here, outside the EVAL-WHEN, seems to be - ;; necessary in order to allow us to put the DEFSTRUCT outside - ;; the EVAL-WHEN.) (setf (def!struct-type-make-load-form-fun ',name) ,(if (symbolp mlff) - `',mlff - mlff) + `',mlff + mlff) (def!struct-supertype ',name) ',def!struct-supertype) ;; This bit of commented-out code hasn't been needed for quite @@ -249,29 +259,29 @@ #+sb-xc-host (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*)) - ;; 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."))) ;;; The STRUCTURE!OBJECT abstract class is the base of the type ;;; hierarchy for objects which have/use DEF!STRUCT functionality. @@ -304,5 +314,5 @@ #+sb-xc-host (defmethod make-load-form ((obj structure!object) &optional (env nil env-p)) (if env-p - (structure!object-make-load-form obj env) - (structure!object-make-load-form obj))) + (structure!object-make-load-form obj env) + (structure!object-make-load-form obj)))