;; 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.
(: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
(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
;; 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
\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
(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
(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)
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)))))))
;;; 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)
(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)))
;;; 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)))
`(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)
(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))
;; 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))
;;; 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)
(vars)
- (types))
+ (types)
+ (skipped-vars))
(labels ((get-slot (name)
(let ((res (find name (dd-slots defstruct)
:test #'string=
(arglist arg)
(vars arg)
(types (get-slot arg)))
-
+
(when opt
(arglist '&optional)
(dolist (arg opt)
(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.
;;;; 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
,slot-name)))
slot-names)
,object-gensym))
-
+
;; predicate
,@(when predicate
;; Just delegate to the compiler's type optimization