From 963d8df14dd061d55ed0447acc9c2621a53e5237 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 12 Dec 2008 10:57:52 +0000 Subject: [PATCH] 1.0.23.36: typecheck :ALLOCATION :CLASS slot initforms in safe code * Initforms for shared slots are not applied at make-instance, but at class definition time. (See CLHS 4.3.6 and 7.1.) Reported by Didier Verna. --- NEWS | 2 ++ src/pcl/init.lisp | 14 +++++------ src/pcl/std-class.lisp | 30 +++++++++++++++++------- tests/clos-typechecking.impure.lisp | 46 +++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 77 insertions(+), 17 deletions(-) diff --git a/NEWS b/NEWS index 096f1e938..f120abb1d 100644 --- a/NEWS +++ b/NEWS @@ -21,6 +21,8 @@ * bug fix: compiling a call to SLOT-VALUE with a constant slot-name when no class with the named slot yet exists no longer causes a compile-time style-warning. + * bug fix: :ALLOCATION :CLASS slots are type-checked properly + in safe code. (reported by Didier Verna) changes in sbcl-1.0.23 relative to 1.0.22: * enhancement: when disassembling method functions, disassembly diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 912c197dc..249e2acc2 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -130,14 +130,12 @@ unless (initialize-slot-from-initarg class instance slotd) collect slotd))) (dolist (slotd initfn-slotds) - (if (eq (slot-definition-allocation slotd) :class) - (when (or (eq t slot-names) - (memq (slot-definition-name slotd) slot-names)) - (unless (slot-boundp-using-class class instance slotd) - (initialize-slot-from-initfunction class instance slotd))) - (when (or (eq t slot-names) - (memq (slot-definition-name slotd) slot-names)) - (initialize-slot-from-initfunction class instance slotd))))) + (unless (eq (slot-definition-allocation slotd) :class) + ;; :ALLOCATION :CLASS slots use the :INITFORM when class is defined + ;; or redefined, not when instances are allocated. + (when (or (eq t slot-names) + (memq (slot-definition-name slotd) slot-names)) + (initialize-slot-from-initfunction class instance slotd))))) instance)) ;;; If initargs are valid return nil, otherwise signal an error. diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index b07aa0c79..c95cf63e1 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -387,6 +387,15 @@ (find-class metaclass))) (t *the-class-standard-class*)) (nreverse reversed-plist))))) + +(defun call-initfun (fun slotd safe) + (declare (function fun)) + (let ((value (funcall fun))) + (when safe + (let ((typecheck (slot-definition-type-check-function slotd))) + (when typecheck + (funcall (the function typecheck) value)))) + value)) (defmethod shared-initialize :after ((class std-class) slot-names &key @@ -406,8 +415,8 @@ super-class of the class ~S, ~ but the meta-classes ~S and ~S are incompatible. ~ Define a method for ~S to avoid this error.~@:>" - superclass class (class-of superclass) (class-of class) - 'validate-superclass))) + superclass class (class-of superclass) (class-of class) + 'validate-superclass))) (setf (slot-value class 'direct-superclasses) direct-superclasses)) (t (setq direct-superclasses (slot-value class 'direct-superclasses)))) @@ -424,6 +433,7 @@ (plist-value class 'direct-default-initargs))) (setf (plist-value class 'class-slot-cells) (let ((old-class-slot-cells (plist-value class 'class-slot-cells)) + (safe (safe-p class)) (collect '())) (dolist (dslotd direct-slots) (when (eq :class (slot-definition-allocation dslotd)) @@ -434,9 +444,10 @@ (eq t slot-names) (member name slot-names :test #'eq)) (let* ((initfunction (slot-definition-initfunction dslotd)) - (value (if initfunction - (funcall initfunction) - +slot-unbound+))) + (value + (if initfunction + (call-initfun initfunction dslotd safe) + +slot-unbound+))) (push (cons name value) collect)) (push old collect))))) (nreverse collect))) @@ -1005,7 +1016,8 @@ (std-compute-slots class)) (defun std-compute-slots-around (class eslotds) - (let ((location -1)) + (let ((location -1) + (safe (safe-p class))) (dolist (eslotd eslotds eslotds) (setf (slot-definition-location eslotd) (case (slot-definition-allocation eslotd) @@ -1029,10 +1041,12 @@ c)))) (aver (consp cell)) (if (eq +slot-unbound+ (cdr cell)) - ;; We may have inherited an initfunction + ;; We may have inherited an initfunction FIXME: Is this + ;; really right? Is the initialization in + ;; SHARED-INITIALIZE (STD-CLASS) not enough? (let ((initfun (slot-definition-initfunction eslotd))) (if initfun - (rplacd cell (funcall initfun)) + (rplacd cell (call-initfun initfun eslotd safe)) cell)) cell))))) (unless (slot-definition-class eslotd) diff --git a/tests/clos-typechecking.impure.lisp b/tests/clos-typechecking.impure.lisp index 87b760221..a8bc8d487 100644 --- a/tests/clos-typechecking.impure.lisp +++ b/tests/clos-typechecking.impure.lisp @@ -242,3 +242,49 @@ (make-instance class :slot :not-a-fixnum)) (assert (raises-error? (make-my-instance 'my-alt-metaclass-instance-class) type-error))) + +(with-test (:name :typecheck-class-allocation) + ;; :CLASS slot :INITFORMs are executed at class definition time + (assert (raises-error? + (eval `(locally (declare (optimize safety)) + (defclass class-allocation-test-bad () + ((slot :initform "slot" + :initarg :slot + :type fixnum + :allocation :class))))) + type-error)) + (let ((name (gensym "CLASS-ALLOCATION-TEST-GOOD"))) + (eval `(locally (declare (optimize safety)) + (defclass ,name () + ((slot :initarg :slot + :type (integer 100 200) + :allocation :class))))) + (eval + `(macrolet ((check (form) + `(assert (multiple-value-bind (ok err) + (ignore-errors ,form) + (and (not ok) + (typep err 'type-error) + (equal '(integer 100 200) + (type-error-expected-type err))))))) + (macrolet ((test (form) + `(progn + (check (eval '(locally (declare (optimize safety)) + ,form))) + (check (funcall (compile nil '(lambda () + (declare (optimize safety)) + ,form)))))) + (test-slot (value form) + `(progn + (assert (eql ,value (slot-value (eval ',form) 'slot))) + (assert (eql ,value (slot-value (funcall (compile nil '(lambda () ,form))) + 'slot)))))) + (test (make-instance ',name :slot :bad)) + (assert (not (slot-boundp (make-instance ',name) 'slot))) + (let ((* (make-instance ',name :slot 101))) + (test-slot 101 *) + (test (setf (slot-value * 'slot) (list 1 2 3))) + (setf (slot-value * 'slot) 110) + (test-slot 110 *)) + (test-slot 110 (make-instance ',name)) + (test-slot 111 (make-instance ',name :slot 111))))))) diff --git a/version.lisp-expr b/version.lisp-expr index 7ed970b5c..5b90791c3 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.23.35" +"1.0.23.36" -- 2.11.4.GIT