X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=e5327913cfe765d520c98262254ea775b6e37cac;hb=34e8e7fd14989e1c86e9408733b4a73c46dd0a92;hp=96c8caa0659ec89f7acb1cebb2d515e9a57eaf6d;hpb=7c5a7fb9e1fb0ade9e31de3ffdf02252669c3d4c;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 96c8caa..e532791 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. @@ -384,6 +412,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) @@ -416,18 +449,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 @@ -444,7 +485,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 @@ -585,7 +626,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) @@ -603,7 +646,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)) @@ -734,12 +781,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))))))) @@ -933,26 +994,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 @@ -1122,9 +1192,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))) @@ -1220,6 +1291,7 @@ ;;; Create a default (non-BOA) keyword constructor. (defun create-keyword-constructor (defstruct creator) + (declare (type function creator)) (collect ((arglist (list '&key)) (types) (vals)) @@ -1236,6 +1308,7 @@ ;;; 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) + (declare (type function creator)) (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux) (parse-lambda-list (second boa)) (collect ((arglist) @@ -1497,8 +1570,12 @@ (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))