;; 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
+ (sb!c:compiler-notify
"implementation limitation: ~
Non-toplevel DEFSTRUCT constructors are slow.")
(with-unique-names (layout)
(let ((inherited (accessor-inherited-data name defstruct)))
(cond
((not inherited)
- (stuff `(proclaim '(inline ,name (setf ,name))))
+ (stuff `(declaim (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
(dsd-index included-slot))
(dd-inherited-accessor-alist dd)
:test #'eq :key #'car))
- (parse-1-dsd dd
- modified
- (copy-structure included-slot)))))))
+ (let ((new-slot (parse-1-dsd dd
+ modified
+ (copy-structure included-slot))))
+ (when (and (neq (dsd-type new-slot) (dsd-type included-slot))
+ (not (subtypep (dsd-type included-slot)
+ (dsd-type new-slot)))
+ (dsd-safe-p included-slot))
+ (setf (dsd-safe-p new-slot) nil)
+ ;; XXX: notify?
+ )))))))
\f
;;;; various helper functions for setting up DEFSTRUCTs
(let ((predicate-name (dd-predicate-name dd)))
(when predicate-name
- (sb!xc:proclaim `(ftype (sfunction (t) t) ,predicate-name))
+ (sb!xc:proclaim `(ftype (sfunction (t) boolean) ,predicate-name))
;; Provide inline expansion (or not).
(ecase (dd-type dd)
((structure funcallable-structure)
(unless (or defaults boas)
(push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
- (collect ((res))
+ (collect ((res) (names))
(when defaults
- (let ((cname (first defaults)))
- (setf (dd-default-constructor defstruct) cname)
- (res (create-keyword-constructor defstruct creator))
- (dolist (other-name (rest defaults))
- (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
- (res `(declaim (ftype function ',other-name))))))
+ (let ((cname (first defaults)))
+ (setf (dd-default-constructor defstruct) cname)
+ (res (create-keyword-constructor defstruct creator))
+ (names cname)
+ (dolist (other-name (rest defaults))
+ (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
+ (names other-name))))
(dolist (boa boas)
- (res (create-boa-constructor defstruct boa creator)))
+ (res (create-boa-constructor defstruct boa creator))
+ (names (first boa)))
+
+ (res `(declaim (ftype
+ (sfunction *
+ ,(if (eq (dd-type defstruct) 'structure)
+ (dd-name defstruct)
+ '*))
+ ,@(names))))
(res))))
\f