X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=a25f997eb41663d3b4d7fd9333a0398f12252540;hb=8922e16df316133288d46695ff2d7596c397a6a0;hp=410759cda6a9b331120af9a88a28b5f3e283c940;hpb=d119bca6cc4e052fe6a043ce76a045713038b06f;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 410759c..a25f997 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) @@ -80,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. @@ -147,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 @@ -159,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 @@ -207,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 @@ -315,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)) @@ -375,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) @@ -382,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. @@ -407,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 @@ -435,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 @@ -576,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) @@ -594,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)) @@ -725,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))))))) @@ -818,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) @@ -924,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 @@ -997,19 +1086,37 @@ (declare (type sb!xc:class class) (type layout old-layout new-layout)) (let ((name (class-proper-name class))) (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 @@ -1095,9 +1202,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))) @@ -1141,7 +1249,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))) @@ -1154,7 +1262,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) @@ -1162,7 +1271,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)) @@ -1176,7 +1286,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) @@ -1187,13 +1296,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)) @@ -1210,11 +1321,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= @@ -1231,7 +1344,7 @@ (arglist arg) (vars arg) (types (get-slot arg))) - + (when opt (arglist '&optional) (dolist (arg opt) @@ -1281,21 +1394,25 @@ (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. @@ -1355,7 +1472,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 @@ -1471,11 +1588,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