From 29003bacae52b0b32626b30e67d6f82a9f4dbce7 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 22 Dec 2008 10:50:35 +0000 Subject: [PATCH] 1.0.23.62: fix bug 357 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. --- BUGS | 46 -------------------------- NEWS | 5 +++ src/pcl/braid.lisp | 14 -------- src/pcl/init.lisp | 19 +++++------ src/pcl/low.lisp | 26 +++++++++------ src/pcl/slots.lisp | 2 +- src/pcl/std-class.lisp | 84 ++++++++++++++++++++++++++---------------------- tests/clos.impure.lisp | 33 +++++++++++++++++++ 8 files changed, 109 insertions(+), 120 deletions(-) diff --git a/BUGS b/BUGS index f92cfa8..1239d6c 100644 --- a/BUGS +++ b/BUGS @@ -1198,52 +1198,6 @@ WORKAROUND: (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: diff --git a/NEWS b/NEWS index e5f7394..9f3de4a 100644 --- a/NEWS +++ b/NEWS @@ -45,6 +45,11 @@ * 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 diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 68daf7f..67df452 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -85,20 +85,6 @@ (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))))) ;;;; BOOTSTRAP-META-BRAID ;;;; diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 249e2ac..6696bba 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -110,20 +110,17 @@ ;; 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) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index cc8f029..bb0b613 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -305,17 +305,23 @@ ;;; 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)) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 4ca5415..2768a42 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -444,7 +444,7 @@ (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. diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 84fcda4..bf80f1b 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -628,51 +628,59 @@ (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 diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 877073c..12a028e 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1674,5 +1674,38 @@ 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)))))) ;;;; success -- 1.7.10.4