Originally reported by Bruno Haible, more recently by Stephen Wilson.
* SHARED-INITIALIZE (SLOT-OBJECT) should not check structure slots
versus +SLOT-UNBOUND+: uninitialized slots are zeroed. Since adding
slots to structure classes cannot cause those slots to be added to
structure instances, we don't really have to check for boundness at
all.
* SB-PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST and
SB-PCL::MAKE-STRUCTURE-CLASS-DEFSTRUCT-FORM did not take overridden
slot specifications into account, and the latter also omitted
initform and type information.
* Delete SB-PCL::ALLOCATE-STRUCTURE-INSTANCE, unused.
* ALLOCATE-INSTANCE (STRUCTURE-OBJECT) should not fall back on
ALLOCATE-STANDARD-INSTANCE.
(make-instance 'bar)
]
-357: defstruct inheritance of initforms
- (reported by Bruno Haible)
- When defstruct and defclass (with :metaclass structure-class) are mixed,
- 1. some slot initforms are ignored by the DEFSTRUCT generated constructor
- function, and
- 2. all slot initforms are ignored by MAKE-INSTANCE. (This can be arguably
- OK for initforms that were given in a DEFSTRUCT form, but for those
- given in a DEFCLASS form, I think it qualifies as a bug.)
- Test case:
- (defstruct structure02a
- slot1
- (slot2 t)
- (slot3 (floor pi)))
- (defclass structure02b (structure02a)
- ((slot4 :initform -44)
- (slot5)
- (slot6 :initform t)
- (slot7 :initform (floor (* pi pi)))
- (slot8 :initform 88))
- (:metaclass structure-class))
- (defstruct (structure02c (:include structure02b (slot8 -88)))
- slot9
- (slot10 t)
- (slot11 (floor (exp 3))))
- ;; 1. Form:
- (let ((a (make-structure02c)))
- (list (structure02c-slot4 a)
- (structure02c-slot5 a)
- (structure02c-slot6 a)
- (structure02c-slot7 a)))
- Expected: (-44 nil t 9)
- Got: (SB-PCL::..SLOT-UNBOUND.. SB-PCL::..SLOT-UNBOUND..
- SB-PCL::..SLOT-UNBOUND.. SB-PCL::..SLOT-UNBOUND..)
- ;; 2. Form:
- (let ((b (make-instance 'structure02c)))
- (list (structure02c-slot2 b)
- (structure02c-slot3 b)
- (structure02c-slot4 b)
- (structure02c-slot6 b)
- (structure02c-slot7 b)
- (structure02c-slot8 b)
- (structure02c-slot10 b)
- (structure02c-slot11 b)))
- Expected: (t 3 -44 t 9 -88 t 20)
- Got: (0 0 0 0 0 0 0 0)
-
359: wrong default value for ensure-generic-function's :generic-function-class argument
(reported by Bruno Haible)
ANSI CL is silent on this, but the MOP's specification of ENSURE-GENERIC-FUNCTION says:
* bug fix: #354; duplicated frames in backtraces due to
non-tail-call-optimized XEPs to functions with return type NIL
have been elimited.
+ * bug fix: #357; MAKE-INSTANCE/SHARED-INITIALIZE now
+ initializes structure object slots according to DEFSTRUCT initforms,
+ and DEFSTRUCT forms :INCLUDEind structure classes defined using
+ DEFCLASS :METACLASS STRUCTURE-CLASS now inherit their initforms.
+ (reported by Bruno Haible and Stephen Wilson)
changes in sbcl-1.0.23 relative to 1.0.22:
* enhancement: when disassembling method functions, disassembly
(allocate-standard-funcallable-instance-slots
wrapper slots-init-p slots-init))
fin))
-
-(defun allocate-structure-instance (wrapper &optional
- (slots-init nil slots-init-p))
- (let* ((class (wrapper-class wrapper))
- (constructor (class-defstruct-constructor class)))
- (if constructor
- (let ((instance (funcall constructor))
- (slots (class-slots class)))
- (when slots-init-p
- (dolist (slot slots)
- (setf (slot-value-using-class class instance slot)
- (pop slots-init))))
- instance)
- (error "can't allocate an instance of class ~S" (class-name class)))))
\f
;;;; BOOTSTRAP-META-BRAID
;;;;
;; that slot won't be initialized from its :INITFORM, if any.
(let ((initfun (slot-definition-initfunction slotd)))
(if (typep instance 'structure-object)
- (when (eq (funcall
- ;; not SLOT-VALUE-USING-CLASS, as that
- ;; throws an error if the value is the
- ;; unbound marker.
- (slot-definition-internal-reader-function slotd)
- instance)
- +slot-unbound+)
+ ;; We don't have a consistent unbound marker for structure
+ ;; object slots, and structure object redefinition is not
+ ;; really supported anyways -- so unconditionally
+ ;; initializing the slot should be fine.
+ (when initfun
(setf (slot-value-using-class class instance slotd)
- (when initfun
- (funcall initfun))))
+ (funcall initfun)))
(unless (or (not initfun)
(slot-boundp-using-class class instance slotd))
- (setf (slot-value-using-class class instance slotd)
- (funcall initfun)))))))
+ (setf (slot-value-using-class class instance slotd)
+ (funcall initfun)))))))
(let* ((class (class-of instance))
(initfn-slotds
(loop for slotd in (class-slots class)
;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp.
-(defun structure-type-included-type-name (type)
- (let ((include (dd-include (find-defstruct-description type))))
- (if (consp include)
- (car include)
- include)))
-
(defun structure-type-slot-description-list (type)
- (nthcdr (length (let ((include (structure-type-included-type-name type)))
- (and include
- (dd-slots (find-defstruct-description include)))))
- (dd-slots (find-defstruct-description type))))
+ (let* ((dd (find-defstruct-description type))
+ (include (dd-include dd))
+ (all-slots (dd-slots dd)))
+ (multiple-value-bind (super slot-overrides)
+ (if (consp include)
+ (values (car include) (mapcar #'car (cdr include)))
+ (values include nil))
+ (let ((included-slots
+ (when super
+ (dd-slots (find-defstruct-description super)))))
+ (loop for slot = (pop all-slots)
+ for included-slot = (pop included-slots)
+ while slot
+ when (or (not included-slot)
+ (member (dsd-name included-slot) slot-overrides :test #'eq))
+ collect slot)))))
(defun structure-slotd-name (slotd)
(dsd-name slotd))
(let ((constructor (class-defstruct-constructor class)))
(if constructor
(funcall constructor)
- (allocate-standard-instance (class-wrapper class)))))
+ (error "Don't know how to allocate ~S" class))))
;;; FIXME: It would be nicer to have allocate-instance return
;;; uninitialized objects for conditions as well.
(defun make-structure-class-defstruct-form (name direct-slots include)
(let* ((conc-name (format-symbol *package* "~S structure class " name))
(constructor (format-symbol *package* "~Aconstructor" conc-name))
- (defstruct `(defstruct (,name
- ,@(when include
- `((:include ,(class-name include))))
- (:predicate nil)
- (:conc-name ,conc-name)
- (:constructor ,constructor ())
- (:copier nil))
- ,@(mapcar (lambda (slot)
- `(,(slot-definition-name slot)
- +slot-unbound+))
- direct-slots)))
- (reader-names (mapcar (lambda (slotd)
- (list 'slot-accessor name
- (slot-definition-name slotd)
- 'reader))
- direct-slots))
- (writer-names (mapcar (lambda (slotd)
- (list 'slot-accessor name
- (slot-definition-name slotd)
- 'writer))
- direct-slots))
- (readers-init
- (mapcar (lambda (slotd reader-name)
- (let ((accessor
+ (included-name (class-name include))
+ (included-slots
+ (when include
+ (mapcar #'dsd-name (dd-slots (find-defstruct-description included-name)))))
+ (old-slots nil)
+ (new-slots nil)
+ (reader-names nil)
+ (writer-names nil))
+ (dolist (slotd (reverse direct-slots))
+ (let* ((slot-name (slot-definition-name slotd))
+ (initform (slot-definition-initform slotd))
+ (type (slot-definition-type slotd))
+ (desc `(,slot-name ,initform :type ,type)))
+ (push `(slot-accessor ,name ,slot-name reader)
+ reader-names)
+ (push `(slot-accessor ,name ,slot-name writer)
+ writer-names)
+ (if (member slot-name included-slots :test #'eq)
+ (push desc old-slots)
+ (push desc new-slots))))
+ (let* ((defstruct `(defstruct (,name
+ ,@(when include
+ `((:include ,included-name
+ ,@old-slots)))
+ (:constructor ,constructor ())
+ (:predicate nil)
+ (:conc-name ,conc-name)
+ (:copier nil))
+ ,@new-slots))
+ (readers-init
+ (mapcar (lambda (slotd reader-name)
+ (let ((accessor
(slot-definition-defstruct-accessor-symbol
slotd)))
- `(defun ,reader-name (obj)
- (declare (type ,name obj))
- (,accessor obj))))
- direct-slots reader-names))
- (writers-init
- (mapcar (lambda (slotd writer-name)
- (let ((accessor
+ `(defun ,reader-name (obj)
+ (declare (type ,name obj))
+ (,accessor obj))))
+ direct-slots reader-names))
+ (writers-init
+ (mapcar (lambda (slotd writer-name)
+ (let ((accessor
(slot-definition-defstruct-accessor-symbol
slotd)))
- `(defun ,writer-name (nv obj)
- (declare (type ,name obj))
- (setf (,accessor obj) nv))))
- direct-slots writer-names))
- (defstruct-form
- `(progn
+ `(defun ,writer-name (nv obj)
+ (declare (type ,name obj))
+ (setf (,accessor obj) nv))))
+ direct-slots writer-names))
+ (defstruct-form
+ `(progn
,defstruct
,@readers-init ,@writers-init
(cons nil nil))))
- (values defstruct-form constructor reader-names writer-names)))
+ (values defstruct-form constructor reader-names writer-names))))
(defun make-defstruct-allocation-function (name)
;; FIXME: Why don't we go class->layout->info == dd
faax)
(with-test (:name :no-implicit-declarations-for-local-specials)
(assert (not (no-implicit-declarations-for-local-specials 1.0d0))))
+
+(defstruct bug-357-a
+ slot1
+ (slot2 t)
+ (slot3 (coerce pi 'single-float) :type single-float))
+(defclass bug-357-b (bug-357-a)
+ ((slot2 :initform 't2)
+ (slot4 :initform -44)
+ (slot5)
+ (slot6 :initform t)
+ (slot7 :initform (floor (* pi pi)))
+ (slot8 :initform 88))
+ (:metaclass structure-class))
+(defstruct (bug-357-c (:include bug-357-b (slot8 -88) (slot5 :ok)))
+ slot9
+ (slot10 t)
+ (slot11 (floor (exp 3))))
+(with-test (:name :bug-357)
+ (flet ((slots (x)
+ (list (bug-357-c-slot1 x)
+ (bug-357-c-slot2 x)
+ (bug-357-c-slot3 x)
+ (bug-357-c-slot4 x)
+ (bug-357-c-slot5 x)
+ (bug-357-c-slot6 x)
+ (bug-357-c-slot7 x)
+ (bug-357-c-slot8 x)
+ (bug-357-c-slot9 x)
+ (bug-357-c-slot10 x)
+ (bug-357-c-slot11 x))))
+ (let ((base (slots (make-bug-357-c))))
+ (assert (equal base (slots (make-instance 'bug-357-c))))
+ (assert (equal base '(nil t2 3.1415927 -44 :ok t 9 -88 nil t 20))))))
\f
;;;; success
projects / sbcl.git / commitdiff