X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefbangstruct.lisp;h=ea2939ebb841f1de8795ceb5f679079f40ed4140;hb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;hp=67e669b916eb85726c039d6d5628b57991307137;hpb=d147d512602d761a2dcdfded506dd1a8f9a140dc;p=sbcl.git diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index 67e669b..ea2939e 100644 --- a/src/code/defbangstruct.lisp +++ b/src/code/defbangstruct.lisp @@ -4,7 +4,10 @@ ;;;; 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. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -25,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)) @@ -68,7 +68,7 @@ (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 @@ -76,8 +76,8 @@ (defun just-dump-it-normally (object &optional (env nil env-p)) (declare (type structure!object object)) (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))) ;;; a MAKE-LOAD-FORM function for objects which don't use the load ;;; form system. This is used for LAYOUT objects because the special @@ -97,7 +97,7 @@ ;; 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 @@ -116,8 +116,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)) @@ -129,10 +130,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 @@ -143,30 +144,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 @@ -179,17 +182,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)) @@ -206,17 +209,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 @@ -246,39 +249,42 @@ #+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 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.) (def!struct (structure!object (:constructor nil))) ;;;; hooking this all into the standard MAKE-LOAD-FORM system +;;; MAKE-LOAD-FORM for DEF!STRUCT-defined types (defun structure!object-make-load-form (object &optional env) - #!+sb-doc - "MAKE-LOAD-FORM for DEF!STRUCT-defined types" (declare (ignore env)) (funcall (def!struct-type-make-load-form-fun (type-of object)) object)) @@ -298,5 +304,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)))