;; 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.
\f
;;;; 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)
(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 "~@<Non-overwritten accessor ~S does not access ~
+ slot with name ~S (accessing an inherited slot ~
+ instead).~:@>" name (dsd-%name slot))))))))
(stuff)))
\f
;;;; parsing
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))
(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)))))))
(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 "~@<Non-overwritten accessor ~S does not access ~
+ slot with name ~S (accessing an inherited slot ~
+ instead).~:@>"
+ accessor-name
+ (dsd-%name dsd)))))))))
(values))
\f
;;;; redefinition stuff
(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)))
(dolist (dsd (dd-slots dd))
(/show0 "doing FDEFINITION for slot accessor")
(let ((accessor-name (dsd-accessor-name dsd)))
- (/show0 "ACCESSOR-NAME=..")
- (/hexstr accessor-name)
- (protect-cl accessor-name)
- (/hexstr "getting READER-FUN and WRITER-FUN")
- (multiple-value-bind (reader-fun writer-fun) (slot-accessor-funs dd dsd)
- (declare (type function reader-fun writer-fun))
- (/show0 "got READER-FUN and WRITER-FUN=..")
- (/hexstr reader-fun)
- (setf (symbol-function accessor-name) reader-fun)
- (unless (dsd-read-only dsd)
- (/show0 "setting FDEFINITION for WRITER-FUN=..")
- (/hexstr writer-fun)
- (setf (fdefinition `(setf ,accessor-name)) writer-fun)))))
+ ;; We mustn't step on any inherited accessors
+ (unless (accessor-inherited-data accessor-name dd)
+ (/show0 "ACCESSOR-NAME=..")
+ (/hexstr accessor-name)
+ (protect-cl accessor-name)
+ (/hexstr "getting READER-FUN and WRITER-FUN")
+ (multiple-value-bind (reader-fun writer-fun)
+ (slot-accessor-funs dd dsd)
+ (declare (type function reader-fun writer-fun))
+ (/show0 "got READER-FUN and WRITER-FUN=..")
+ (/hexstr reader-fun)
+ (setf (symbol-function accessor-name) reader-fun)
+ (unless (dsd-read-only dsd)
+ (/show0 "setting FDEFINITION for WRITER-FUN=..")
+ (/hexstr writer-fun)
+ (setf (fdefinition `(setf ,accessor-name)) writer-fun))))))
;; Set FDEFINITION for copier.
(when (dd-copier-name dd)
(defstruct person age (name 007 :type string)) ; not an error until 007 used
(make-person :name "James") ; not an error, 007 not used
(assert (raises-error? (make-person) type-error))
-;;; FIXME: broken structure slot type checking in sbcl-0.pre7.62
-#+nil (assert (raises-error? (setf (person-name (make-person "Q")) 1) type-error))
+(assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
+ type-error))
;;; basic inheritance
(defstruct (astronaut (:include person)
(assert (eq (foo-0-7-8-53-x foo-0-7-8-53) :s))
(assert (eq (foo-0-7-8-53-y foo-0-7-8-53) :not)))
\f
+;;; tests of behaviour of colliding accessors.
+(defstruct (bug127-foo (:conc-name bug127-baz-)) a)
+(assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
+(defstruct (bug127-bar (:conc-name bug127-baz-) (:include bug127-foo)) b)
+(assert (= (bug127-baz-a (make-bug127-bar :a 1 :b 2)) 1))
+(assert (= (bug127-baz-b (make-bug127-bar :a 1 :b 2)) 2))
+(assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
+
+(defun bug127-flurble (x)
+ x)
+(defstruct bug127 flurble)
+(assert (= (bug127-flurble (make-bug127 :flurble 7)) 7))
+
+(defstruct bug127-a b-c)
+(assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
+(defstruct (bug127-a-b (:include bug127-a)) c)
+(assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
+(assert (= (bug127-a-b-c (make-bug127-a-b :b-c 11 :c 13)) 11))
+
+(defstruct (bug127-e (:conc-name bug127--)) foo)
+(assert (= (bug127--foo (make-bug127-e :foo 3)) 3))
+(defstruct (bug127-f (:conc-name bug127--)) foo)
+(assert (= (bug127--foo (make-bug127-f :foo 3)) 3))
+(assert (raises-error? (bug127--foo (make-bug127-e :foo 3)) type-error))
+
+;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
+\f
;;; success
(format t "~&/returning success~%")
(quit :unix-status 104)
projects / sbcl.git / commitdiff