X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=6822ef22ea3d987b5fd0a9fb4d1aba8eb59c33d5;hb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;hp=d06c83930a5e9f51c4a5160087a75b04b14105a8;hpb=08307967c71c580058a503d46aa087cfefcf8c69;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index d06c839..6822ef2 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -27,10 +27,36 @@ (t res)))) ;;; Delay looking for compiler-layout until the constructor is being -;;; compiled, since it doesn't exist until after the EVAL-WHEN (COMPILE) -;;; stuff is compiled. +;;; compiled, since it doesn't exist until after the EVAL-WHEN +;;; (COMPILE) stuff is compiled. (Or, in the oddball case when +;;; DEFSTRUCT is executing in a non-toplevel context, the +;;; compiler-layout still doesn't exist at compilation time, and we +;;; delay still further.) (sb!xc:defmacro %delayed-get-compiler-layout (name) - `',(compiler-layout-or-lose name)) + (let ((layout (info :type :compiler-layout name))) + (cond (layout + ;; ordinary case: When the DEFSTRUCT is at top level, + ;; then EVAL-WHEN (COMPILE) stuff will have set up the + ;; layout for us to use. + (unless (typep (layout-info layout) 'defstruct-description) + (error "Class is not a structure class: ~S" name)) + `,layout) + (t + ;; KLUDGE: In the case that DEFSTRUCT is not at top-level + ;; the layout doesn't exist at compile time. In that case + ;; we laboriously look it up at run time. This code will + ;; run on every constructor call and will likely be quite + ;; slow, so if anyone cares about performance of + ;; non-toplevel DEFSTRUCTs, it should be rewritten to be + ;; cleverer. -- WHN 2002-10-23 + (sb!c::compiler-note + "implementation limitation: ~ + Non-toplevel DEFSTRUCT constructors are slow.") + (let ((layout (gensym "LAYOUT"))) + `(let ((,layout (info :type :compiler-layout ',name))) + (unless (typep (layout-info ,layout) 'defstruct-description) + (error "Class is not a structure class: ~S" ',name)) + ,layout)))))) ;;; Get layout right away. (sb!xc:defmacro compile-time-find-layout (name) @@ -50,21 +76,25 @@ (:conc-name dd-) (:make-load-form-fun just-dump-it-normally) #-sb-xc-host (:pure t) - (:constructor make-defstruct-description (name))) + (:constructor make-defstruct-description + (name &aux + (conc-name (symbolicate name "-")) + (copier-name (symbolicate "COPY-" name)) + (predicate-name (symbolicate name "-P"))))) ;; name of the structure - (name (missing-arg) :type symbol) + (name (missing-arg) :type symbol :read-only t) ;; documentation on the structure (doc nil :type (or string null)) ;; prefix for slot names. If NIL, none. - (conc-name (symbolicate name "-") :type (or symbol null)) + (conc-name nil :type (or symbol null)) ;; the name of the primary standard keyword constructor, or NIL if none (default-constructor nil :type (or symbol null)) ;; all the explicit :CONSTRUCTOR specs, with name defaulted (constructors () :type list) ;; name of copying function - (copier-name (symbolicate "COPY-" name) :type (or symbol null)) + (copier-name nil :type (or symbol null)) ;; name of type predicate - (predicate-name (symbolicate name "-P") :type (or symbol null)) + (predicate-name nil :type (or symbol null)) ;; the arguments to the :INCLUDE option, or NIL if no included ;; structure (include nil :type list) @@ -76,6 +106,8 @@ ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots ;; (including included ones) (slots () :type list) + ;; a list of (NAME . INDEX) pairs for accessors of included structures + (inherited-accessor-alist () :type list) ;; number of elements we've allocated (See also RAW-LENGTH.) (length 0 :type index) ;; General kind of implementation. @@ -143,7 +175,7 @@ (:copier nil) #-sb-xc-host (:pure t)) ;; string name of slot - %name + %name ;; its position in the implementation sequence (index (missing-arg) :type fixnum) ;; the name of the accessor function @@ -155,6 +187,8 @@ (accessor-name nil) default ; default value expression (type t) ; declared type specifier + (safe-p t :type boolean) ; whether the slot is known to be + ; always of the specified type ;; If this object does not describe a raw slot, this value is T. ;; ;; If this object describes a raw slot, this value is the type of the @@ -203,11 +237,11 @@ ;; What operator is used (on the raw data vector) to access a slot ;; of this type? (accessor-name (missing-arg) :type symbol :read-only t) - ;; How many words are each value of this type? (This is used to + ;; How many words are each value of this type? (This is used to ;; rescale the offset into the raw data vector.) (n-words (missing-arg) :type (and index (integer 1)) :read-only t)) - (defvar *raw-slot-data-list* + (defvar *raw-slot-data-list* (list ;; The compiler thinks that the raw data vector is a vector of ;; word-sized unsigned bytes, so if the slot we want to access @@ -255,7 +289,7 @@ ;; class names which creates fast but non-cold-loadable, ;; non-compact code. In this context, we'd rather have ;; compact, cold-loadable code. -- WHN 19990928 - (declare (notinline sb!xc:find-class)) + (declare (notinline find-classoid)) ,@(let ((pf (dd-print-function defstruct)) (po (dd-print-object defstruct)) (x (gensym)) @@ -274,23 +308,26 @@ fun-name))) (cond ((not (eql pf 0)) `((def!method print-object ((,x ,name) ,s) - (funcall #',(farg pf) ,x ,s *current-level*)))) + (funcall #',(farg pf) + ,x + ,s + *current-level-in-print*)))) ((not (eql po 0)) `((def!method print-object ((,x ,name) ,s) (funcall #',(farg po) ,x ,s)))) (t nil)))) ,@(let ((pure (dd-pure defstruct))) (cond ((eq pure t) - `((setf (layout-pure (class-layout - (sb!xc:find-class ',name))) + `((setf (layout-pure (classoid-layout + (find-classoid ',name))) t))) ((eq pure :substructure) - `((setf (layout-pure (class-layout - (sb!xc:find-class ',name))) + `((setf (layout-pure (classoid-layout + (find-classoid ',name))) 0))))) ,@(let ((def-con (dd-default-constructor defstruct))) (when (and def-con (not (dd-alternate-metaclass defstruct))) - `((setf (structure-class-constructor (sb!xc:find-class ',name)) + `((setf (structure-classoid-constructor (find-classoid ',name)) #',def-con)))))))) ;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT @@ -308,14 +345,23 @@ (if (dd-class-p dd) (let ((inherits (inherits-for-structure dd))) `(progn + ;; Note we intentionally call %DEFSTRUCT first, and + ;; especially before %COMPILER-DEFSTRUCT. %DEFSTRUCT + ;; has the tests (and resulting CERROR) for collisions + ;; with LAYOUTs which already exist in the runtime. If + ;; there are any collisions, we want the user's + ;; response to CERROR to control what happens. + ;; Especially, if the user responds to the collision + ;; with ABORT, we don't want %COMPILER-DEFSTRUCT to + ;; modify the definition of the class. + (%defstruct ',dd ',inherits) (eval-when (:compile-toplevel :load-toplevel :execute) (%compiler-defstruct ',dd ',inherits)) - (%defstruct ',dd ',inherits) ,@(unless expanding-into-code-for-xc-host-p (append ;; FIXME: We've inherited from CMU CL nonparallel ;; code for creating copiers for typed and untyped ;; structures. This should be fixed. - ;(copier-definition dd) + ;(copier-definition dd) (constructor-definitions dd) (class-method-definitions dd))) ',name)) @@ -368,6 +414,11 @@ ;;;; functions to generate code for various parts of DEFSTRUCT definitions +;;; First, a helper to determine whether a name names an inherited +;;; accessor. +(defun accessor-inherited-data (name defstruct) + (assoc name (dd-inherited-accessor-alist defstruct) :test #'eq)) + ;;; Return a list of forms which create a predicate function for a ;;; typed DEFSTRUCT. (defun typed-predicate-definitions (defstruct) @@ -375,11 +426,20 @@ (predicate-name (dd-predicate-name defstruct)) (argname (gensym))) (when (and predicate-name (dd-named defstruct)) - (let ((ltype (dd-lisp-type defstruct))) + (let ((ltype (dd-lisp-type defstruct)) + (name-index (cdr (car (last (find-name-indices defstruct)))))) `((defun ,predicate-name (,argname) (and (typep ,argname ',ltype) + ,(cond + ((subtypep ltype 'list) + `(consp (nthcdr ,name-index (the ,ltype ,argname)))) + ((subtypep ltype 'vector) + `(= (length (the ,ltype ,argname)) + ,(dd-length defstruct))) + (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S." + ltype))) (eq (elt (the ,ltype ,argname) - ,(cdr (car (last (find-name-indices defstruct))))) + ,name-index) ',name)))))))) ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT. @@ -400,18 +460,26 @@ (index (dsd-index slot)) (slot-type `(and ,(dsd-type slot) ,(dd-element-type defstruct)))) - (stuff `(proclaim '(inline ,name (setf ,name)))) - ;; FIXME: The arguments in the next two DEFUNs should be - ;; gensyms. (Otherwise e.g. if NEW-VALUE happened to be the - ;; name of a special variable, things could get weird.) - (stuff `(defun ,name (structure) - (declare (type ,ltype structure)) - (the ,slot-type (elt structure ,index)))) - (unless (dsd-read-only slot) - (stuff - `(defun (setf ,name) (new-value structure) - (declare (type ,ltype structure) (type ,slot-type new-value)) - (setf (elt structure ,index) new-value))))))) + (let ((inherited (accessor-inherited-data name defstruct))) + (cond + ((not inherited) + (stuff `(proclaim '(inline ,name (setf ,name)))) + ;; FIXME: The arguments in the next two DEFUNs should + ;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to + ;; be the name of a special variable, things could get + ;; weird.) + (stuff `(defun ,name (structure) + (declare (type ,ltype structure)) + (the ,slot-type (elt structure ,index)))) + (unless (dsd-read-only slot) + (stuff + `(defun (setf ,name) (new-value structure) + (declare (type ,ltype structure) (type ,slot-type new-value)) + (setf (elt structure ,index) new-value))))) + ((not (= (cdr inherited) index)) + (style-warn "~@" name (dsd-%name slot)))))))) (stuff))) ;;;; parsing @@ -428,7 +496,7 @@ (name (dd-name dd))) (case (first option) (:conc-name - (destructuring-bind (conc-name) args + (destructuring-bind (&optional conc-name) args (setf (dd-conc-name dd) (if (symbolp conc-name) conc-name @@ -569,7 +637,9 @@ (setf (dsd-%name slot) (string name)) (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot))) - (let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name)) + (let ((accessor-name (if (dd-conc-name defstruct) + (symbolicate (dd-conc-name defstruct) name) + name)) (predicate-name (dd-predicate-name defstruct))) (setf (dsd-accessor-name slot) accessor-name) (when (eql accessor-name predicate-name) @@ -587,7 +657,11 @@ accessor, but you can't rely on this behavior, so it'd be wise to ~ remove the ambiguity in your code.~@:>" accessor-name) - (setf (dd-predicate-name defstruct) nil))) + (setf (dd-predicate-name defstruct) nil)) + #-sb-xc-host + (when (and (fboundp accessor-name) + (not (accessor-inherited-data accessor-name defstruct))) + (style-warn "redefining ~S in DEFSTRUCT" accessor-name))) (when default-p (setf (dsd-default slot) default)) @@ -690,12 +764,12 @@ (specifier-type (dd-element-type dd)))) (error ":TYPE option mismatch between structures ~S and ~S" (dd-name dd) included-name)) - (let ((included-class (sb!xc:find-class included-name nil))) - (when included-class + (let ((included-classoid (find-classoid included-name nil))) + (when included-classoid ;; It's not particularly well-defined to :INCLUDE any of the ;; CMU CL INSTANCE weirdosities like CONDITION or ;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant. - (let* ((included-layout (class-layout included-class)) + (let* ((included-layout (classoid-layout included-classoid)) (included-dd (layout-info included-layout))) (when (and (dd-alternate-metaclass included-dd) ;; As of sbcl-0.pre7.73, anyway, STRUCTURE-OBJECT @@ -718,12 +792,26 @@ (setf (dd-raw-index dd) (dd-raw-index included-structure)) (setf (dd-raw-length dd) (dd-raw-length included-structure))) + (setf (dd-inherited-accessor-alist dd) + (dd-inherited-accessor-alist included-structure)) (dolist (included-slot (dd-slots included-structure)) (let* ((included-name (dsd-name included-slot)) (modified (or (find included-name modified-slots :key (lambda (x) (if (atom x) x (car x))) :test #'string=) `(,included-name)))) + ;; We stash away an alist of accessors to parents' slots + ;; that have already been created to avoid conflicts later + ;; so that structures with :INCLUDE and :CONC-NAME (and + ;; other edge cases) can work as specified. + (when (dsd-accessor-name included-slot) + ;; the "oldest" (i.e. highest up the tree of inheritance) + ;; will prevail, so don't push new ones on if they + ;; conflict. + (pushnew (cons (dsd-accessor-name included-slot) + (dsd-index included-slot)) + (dd-inherited-accessor-alist dd) + :test #'eq :key #'car)) (parse-1-dsd dd modified (copy-structure included-slot))))))) @@ -739,15 +827,15 @@ (super (if include (compiler-layout-or-lose (first include)) - (class-layout (sb!xc:find-class - (or (first superclass-opt) - 'structure-object)))))) + (classoid-layout (find-classoid + (or (first superclass-opt) + 'structure-object)))))) (if (eq (dd-name info) 'ansi-stream) ;; a hack to add the CL:STREAM class as a mixin for ANSI-STREAMs (concatenate 'simple-vector (layout-inherits super) (vector super - (class-layout (sb!xc:find-class 'stream)))) + (classoid-layout (find-classoid 'stream)))) (concatenate 'simple-vector (layout-inherits super) (vector super))))) @@ -761,10 +849,10 @@ (declare (type defstruct-description dd)) ;; We set up LAYOUTs even in the cross-compilation host. - (multiple-value-bind (class layout old-layout) + (multiple-value-bind (classoid layout old-layout) (ensure-structure-class dd inherits "current" "new") (cond ((not old-layout) - (unless (eq (class-layout class) layout) + (unless (eq (classoid-layout classoid) layout) (register-layout layout))) (t (let ((old-dd (layout-info old-layout))) @@ -773,9 +861,9 @@ (fmakunbound (dsd-accessor-name slot)) (unless (dsd-read-only slot) (fmakunbound `(setf ,(dsd-accessor-name slot))))))) - (%redefine-defstruct class old-layout layout) - (setq layout (class-layout class)))) - (setf (sb!xc:find-class (dd-name dd)) class) + (%redefine-defstruct classoid old-layout layout) + (setq layout (classoid-layout classoid)))) + (setf (find-classoid (dd-name dd)) classoid) ;; Various other operations only make sense on the target SBCL. #-sb-xc-host @@ -811,17 +899,16 @@ ;;; and writer functions of the slot described by DSD. (defun slot-accessor-inline-expansion-designators (dd dsd) (let ((instance-type-decl `(declare (type ,(dd-name dd) instance))) - (accessor-place-form (%accessor-place-form dd dsd 'instance)) - (dsd-type (dsd-type dsd))) - (values (lambda () - `(lambda (instance) - ,instance-type-decl - (truly-the ,dsd-type ,accessor-place-form))) - (lambda () - `(lambda (new-value instance) - (declare (type ,dsd-type new-value)) - ,instance-type-decl - (setf ,accessor-place-form new-value)))))) + (accessor-place-form (%accessor-place-form dd dsd 'instance)) + (dsd-type (dsd-type dsd)) + (value-the (if (dsd-safe-p dsd) 'truly-the 'the))) + (values (lambda () `(lambda (instance) + ,instance-type-decl + (,value-the ,dsd-type ,accessor-place-form))) + (lambda () `(lambda (new-value instance) + (declare (type ,dsd-type new-value)) + ,instance-type-decl + (setf ,accessor-place-form new-value)))))) ;;; Return a LAMBDA form which can be used to set a slot. (defun slot-setter-lambda-form (dd dsd) @@ -841,7 +928,7 @@ (inherits (vector (find-layout t) (find-layout 'instance)))) - (multiple-value-bind (class layout old-layout) + (multiple-value-bind (classoid layout old-layout) (multiple-value-bind (clayout clayout-p) (info :type :compiler-layout (dd-name dd)) (ensure-structure-class dd @@ -850,27 +937,27 @@ "compiled" :compiler-layout clayout)) (cond (old-layout - (undefine-structure (layout-class old-layout)) - (when (and (class-subclasses class) + (undefine-structure (layout-classoid old-layout)) + (when (and (classoid-subclasses classoid) (not (eq layout old-layout))) (collect ((subs)) - (dohash (class layout (class-subclasses class)) + (dohash (classoid layout (classoid-subclasses classoid)) (declare (ignore layout)) - (undefine-structure class) - (subs (class-proper-name class))) + (undefine-structure classoid) + (subs (classoid-proper-name classoid))) (when (subs) (warn "removing old subclasses of ~S:~% ~S" - (sb!xc:class-name class) + (classoid-name classoid) (subs)))))) (t - (unless (eq (class-layout class) layout) + (unless (eq (classoid-layout classoid) layout) (register-layout layout :invalidate nil)) - (setf (sb!xc:find-class (dd-name dd)) class))) + (setf (find-classoid (dd-name dd)) classoid))) ;; At this point the class should be set up in the INFO database. ;; But the logic that enforces this is a little tangled and ;; scattered, so it's not obvious, so let's check. - (aver (sb!xc:find-class (dd-name dd) nil)) + (aver (find-classoid (dd-name dd) nil)) (setf (info :type :compiler-layout (dd-name dd)) layout)) @@ -883,9 +970,7 @@ (%compiler-set-up-layout dd inherits) - (let* ((dd-name (dd-name dd)) - (dtype (dd-declarable-type dd)) - (class (sb!xc:find-class dd-name))) + (let* ((dtype (dd-declarable-type dd))) (let ((copier-name (dd-copier-name dd))) (when copier-name @@ -919,26 +1004,35 @@ (let* ((accessor-name (dsd-accessor-name dsd)) (dsd-type (dsd-type dsd))) (when accessor-name - (multiple-value-bind (reader-designator writer-designator) - (slot-accessor-inline-expansion-designators dd dsd) - (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type) - ,accessor-name)) - (setf (info :function :inline-expansion-designator accessor-name) - reader-designator - (info :function :inlinep accessor-name) - :inline) - (unless (dsd-read-only dsd) - (let ((setf-accessor-name `(setf ,accessor-name))) - (sb!xc:proclaim - `(ftype (function (,dsd-type ,dtype) ,dsd-type) - ,setf-accessor-name)) - (setf (info :function - :inline-expansion-designator - setf-accessor-name) - writer-designator - (info :function :inlinep setf-accessor-name) - :inline)))))))) - + (let ((inherited (accessor-inherited-data accessor-name dd))) + (cond + ((not inherited) + (multiple-value-bind (reader-designator writer-designator) + (slot-accessor-inline-expansion-designators dd dsd) + (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type) + ,accessor-name)) + (setf (info :function :inline-expansion-designator + accessor-name) + reader-designator + (info :function :inlinep accessor-name) + :inline) + (unless (dsd-read-only dsd) + (let ((setf-accessor-name `(setf ,accessor-name))) + (sb!xc:proclaim + `(ftype (function (,dsd-type ,dtype) ,dsd-type) + ,setf-accessor-name)) + (setf (info :function + :inline-expansion-designator + setf-accessor-name) + writer-designator + (info :function :inlinep setf-accessor-name) + :inline))))) + ((not (= (cdr inherited) (dsd-index dsd))) + (style-warn "~@" + accessor-name + (dsd-%name dsd))))))))) (values)) ;;;; redefinition stuff @@ -968,10 +1062,10 @@ ;;; If we are redefining a structure with different slots than in the ;;; currently loaded version, give a warning and return true. -(defun redefine-structure-warning (class old new) +(defun redefine-structure-warning (classoid old new) (declare (type defstruct-description old new) - (type sb!xc:class class) - (ignore class)) + (type classoid classoid) + (ignore classoid)) (let ((name (dd-name new))) (multiple-value-bind (moved retyped deleted) (compare-slots old new) (when (or moved retyped deleted) @@ -988,23 +1082,42 @@ ;;; structure CLASS to have the specified NEW-LAYOUT. We signal an ;;; error with some proceed options and return the layout that should ;;; be used. -(defun %redefine-defstruct (class old-layout new-layout) - (declare (type sb!xc:class class) (type layout old-layout new-layout)) - (let ((name (class-proper-name class))) +(defun %redefine-defstruct (classoid old-layout new-layout) + (declare (type classoid classoid) + (type layout old-layout new-layout)) + (let ((name (classoid-proper-name classoid))) (restart-case - (error "redefining class ~S incompatibly with the current definition" + (error "~@" + 'structure-object name) (continue () - :report "Invalidate current definition." - (warn "Previously loaded ~S accessors will no longer work." name) - (register-layout new-layout)) + :report (lambda (s) + (format s + "~@" + name)) + (register-layout new-layout)) + (recklessly-continue () + :report (lambda (s) + (format s + "~@" + name)) + ;; classic CMU CL warning: "Any old ~S instances will be in a bad way. + ;; I hope you know what you're doing..." + (register-layout new-layout + :invalidate nil + :destruct-layout old-layout)) (clobber-it () - :report "Smash current layout, preserving old code." - (warn "Any old ~S instances will be in a bad way.~@ - I hope you know what you're doing..." - name) - (register-layout new-layout :invalidate nil - :destruct-layout old-layout)))) + ;; FIXME: deprecated 2002-10-16, and since it's only interactive + ;; hackery instead of a supported feature, can probably be deleted + ;; in early 2003 + :report "(deprecated synonym for RECKLESSLY-CONTINUE)" + (register-layout new-layout + :invalidate nil + :destruct-layout old-layout)))) (values)) ;;; This is called when we are about to define a structure class. It @@ -1019,24 +1132,25 @@ (destructuring-bind (&optional name - (class 'sb!xc:structure-class) - (constructor 'make-structure-class)) + (class 'structure-classoid) + (constructor 'make-structure-classoid)) (dd-alternate-metaclass info) (declare (ignore name)) - (insured-find-class (dd-name info) - (if (eq class 'sb!xc:structure-class) - (lambda (x) - (typep x 'sb!xc:structure-class)) - (lambda (x) - (sb!xc:typep x (sb!xc:find-class class)))) - (fdefinition constructor))) - (setf (class-direct-superclasses class) + (insured-find-classoid (dd-name info) + (if (eq class 'structure-classoid) + (lambda (x) + (sb!xc:typep x 'structure-classoid)) + (lambda (x) + (sb!xc:typep x (find-classoid class)))) + (fdefinition constructor))) + (setf (classoid-direct-superclasses class) (if (eq (dd-name info) 'ansi-stream) ;; a hack to add CL:STREAM as a superclass mixin to ANSI-STREAMs - (list (layout-class (svref inherits (1- (length inherits)))) - (layout-class (svref inherits (- (length inherits) 2)))) - (list (layout-class (svref inherits (1- (length inherits))))))) - (let ((new-layout (make-layout :class class + (list (layout-classoid (svref inherits (1- (length inherits)))) + (layout-classoid (svref inherits (- (length inherits) 2)))) + (list (layout-classoid + (svref inherits (1- (length inherits))))))) + (let ((new-layout (make-layout :classoid class :inherits inherits :depthoid (length inherits) :length (dd-length info) @@ -1048,7 +1162,7 @@ (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING ;; of classic CMU CL. I moved it out to here because it was only ;; exercised in this code path anyway. -- WHN 19990510 - (not (eq (layout-class new-layout) (layout-class old-layout))) + (not (eq (layout-classoid new-layout) (layout-classoid old-layout))) (error "shouldn't happen: weird state of OLD-LAYOUT?")) ((not *type-system-initialized*) (setf (layout-info old-layout) info) @@ -1081,7 +1195,7 @@ ;;; over this type, clearing the compiler structure type info, and ;;; undefining all the associated functions. (defun undefine-structure (class) - (let ((info (layout-info (class-layout class)))) + (let ((info (layout-info (classoid-layout class)))) (when (defstruct-description-p info) (let ((type (dd-name info))) (remhash type *typecheckfuns*) @@ -1090,9 +1204,10 @@ (undefine-fun-name (dd-predicate-name info)) (dolist (slot (dd-slots info)) (let ((fun (dsd-accessor-name slot))) - (undefine-fun-name fun) - (unless (dsd-read-only slot) - (undefine-fun-name `(setf ,fun)))))) + (unless (accessor-inherited-data fun info) + (undefine-fun-name fun) + (unless (dsd-read-only slot) + (undefine-fun-name `(setf ,fun))))))) ;; Clear out the SPECIFIER-TYPE cache so that subsequent ;; references are unknown types. (values-specifier-type-cache-clear))) @@ -1136,7 +1251,7 @@ ;;; structures can have arbitrary subtypes of VECTOR, not necessarily ;;; SIMPLE-VECTOR.) ;;; * STRUCTURE structures can have raw slots that must also be -;;; allocated and indirectly referenced. +;;; allocated and indirectly referenced. (defun create-vector-constructor (dd cons-name arglist vars types values) (let ((temp (gensym)) (etype (dd-element-type dd))) @@ -1149,7 +1264,8 @@ `(setf (aref ,temp ,(cdr x)) ',(car x))) (find-name-indices dd)) ,@(mapcar (lambda (dsd value) - `(setf (aref ,temp ,(dsd-index dsd)) ,value)) + (unless (eq value '.do-not-initialize-slot.) + `(setf (aref ,temp ,(dsd-index dsd)) ,value))) (dd-slots dd) values) ,temp)))) (defun create-list-constructor (dd cons-name arglist vars types values) @@ -1157,7 +1273,8 @@ (dolist (x (find-name-indices dd)) (setf (elt vals (cdr x)) `',(car x))) (loop for dsd in (dd-slots dd) and val in values do - (setf (elt vals (dsd-index dsd)) val)) + (setf (elt vals (dsd-index dsd)) + (if (eq val '.do-not-initialize-slot.) 0 val))) `(defun ,cons-name ,arglist (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types)) @@ -1171,7 +1288,6 @@ (let ((,instance (truly-the ,(dd-name dd) (%make-instance-with-layout (%delayed-get-compiler-layout ,(dd-name dd)))))) - (declare (optimize (safety 0))) ; Suppress redundant slot type checks. ,@(when raw-index `((setf (%instance-ref ,instance ,raw-index) (make-array ,(dd-raw-length dd) @@ -1182,13 +1298,15 @@ ;; because the slot might be :READ-ONLY, so we ;; whip up new LAMBDA representations of slot ;; setters for the occasion.) - `(,(slot-setter-lambda-form dd dsd) ,value ,instance)) + (unless (eq value '.do-not-initialize-slot.) + `(,(slot-setter-lambda-form dd dsd) ,value ,instance))) (dd-slots dd) values) ,instance)))) ;;; Create a default (non-BOA) keyword constructor. (defun create-keyword-constructor (defstruct creator) + (declare (type function creator)) (collect ((arglist (list '&key)) (types) (vals)) @@ -1205,11 +1323,13 @@ ;;; Given a structure and a BOA constructor spec, call CREATOR with ;;; the appropriate args to make a constructor. (defun create-boa-constructor (defstruct boa creator) - (multiple-value-bind (req opt restp rest keyp keys allowp aux) - (sb!kernel:parse-lambda-list (second boa)) + (declare (type function creator)) + (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux) + (parse-lambda-list (second boa)) (collect ((arglist) (vars) - (types)) + (types) + (skipped-vars)) (labels ((get-slot (name) (let ((res (find name (dd-slots defstruct) :test #'string= @@ -1226,15 +1346,22 @@ (arglist arg) (vars arg) (types (get-slot arg))) - + (when opt (arglist '&optional) (dolist (arg opt) (cond ((consp arg) (destructuring-bind - (name &optional (def (nth-value 1 (get-slot name)))) + ;; FIXME: this shares some logic (though not + ;; code) with the &key case below (and it + ;; looks confusing) -- factor out the logic + ;; if possible. - CSR, 2002-04-19 + (name + &optional + (def (nth-value 1 (get-slot name))) + (supplied-test nil supplied-test-p)) arg - (arglist `(,name ,def)) + (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil))) (vars name) (types (get-slot name)))) (t @@ -1249,35 +1376,45 @@ (arglist '&key) (dolist (key keys) (if (consp key) - (destructuring-bind (wot &optional (def nil def-p)) key + (destructuring-bind (wot + &optional + (def nil def-p) + (supplied-test nil supplied-test-p)) + key (let ((name (if (consp wot) (destructuring-bind (key var) wot (declare (ignore key)) var) wot))) - (multiple-value-bind (type slot-def) (get-slot name) - (arglist `(,wot ,(if def-p def slot-def))) + (multiple-value-bind (type slot-def) + (get-slot name) + (arglist `(,wot ,(if def-p def slot-def) + ,@(if supplied-test-p `(,supplied-test) nil))) (vars name) (types type)))) (do-default key)))) (when allowp (arglist '&allow-other-keys)) - (when aux + (when auxp (arglist '&aux) (dolist (arg aux) - (let* ((arg (if (consp arg) arg (list arg))) - (var (first arg))) - (arglist arg) - (vars var) - (types (get-slot var)))))) + (arglist arg) + (if (proper-list-of-length-p arg 2) + (let ((var (first arg))) + (vars var) + (types (get-slot var))) + (skipped-vars (if (consp arg) (first arg) arg)))))) (funcall creator defstruct (first boa) (arglist) (vars) (types) - (mapcar (lambda (slot) - (or (find (dsd-name slot) (vars) :test #'string=) - (dsd-default slot))) - (dd-slots defstruct)))))) + (loop for slot in (dd-slots defstruct) + for name = (dsd-name slot) + collect (cond ((find name (skipped-vars) :test #'string=) + (setf (dsd-safe-p slot) nil) + '.do-not-initialize-slot.) + ((or (find (dsd-name slot) (vars) :test #'string=) + (dsd-default slot))))))))) ;;; Grovel the constructor options, and decide what constructors (if ;;; any) to create. @@ -1337,7 +1474,7 @@ ;;;; main DEFSTRUCT macro. Hopefully it will go away presently ;;;; (perhaps when CL:CLASS and SB-PCL:CLASS meet) as per FIXME below. ;;;; -- WHN 2001-10-28 -;;;; +;;;; ;;;; FIXME: There seems to be no good reason to shoehorn CONDITION, ;;;; STANDARD-INSTANCE, and GENERIC-FUNCTION into mutated structures ;;;; instead of just implementing them as primitive objects. (This @@ -1402,7 +1539,6 @@ :metaclass-name metaclass-name :metaclass-constructor metaclass-constructor :dd-type dd-type)) - (conc-name (concatenate 'string (symbol-name class-name) "-")) (dd-slots (dd-slots dd)) (dd-length (1+ (length slot-names))) (object-gensym (gensym "OBJECT")) @@ -1454,11 +1590,15 @@ (let ((dsd (find (symbol-name slot-name) dd-slots :key #'dsd-%name :test #'string=))) + ;; KLUDGE: bug 117 bogowarning. Neither + ;; DECLAREing the type nor TRULY-THE cut + ;; the mustard -- it still gives warnings. + (enforce-type dsd defstruct-slot-description) `(setf (,(dsd-accessor-name dsd) ,object-gensym) - ,slot-name))) + ,slot-name))) slot-names) ,object-gensym)) - + ;; predicate ,@(when predicate ;; Just delegate to the compiler's type optimization