Commit 714f87af authored by rtoy's avatar rtoy
Browse files

Trac Ticket #26: slot-value type check. 

This fixes the setf slot-value issue

methods.lisp:
o Add explicit type check to SETF-SLOT-VALUE-USING-CLASS-DFUN to check
  that the new value has the expected type for the slot.

rt/slot-type.lisp:
o Add test to make verify this.
parent c52c2a3f

pcl/methods.lisp

+10 −1
Original line number Diff line number Diff line
@@ -26,7 +26,7 @@ 
;;;



(file-comment

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.45 2008/03/25 15:05:53 rtoy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.46 2008/12/02 18:18:34 rtoy Exp $")



(in-package :pcl)
@@ -1522,6 +1522,15 @@ 


(defun setf-slot-value-using-class-dfun (new-value class object slotd)

  (declare (ignore class))

  ;; This is essentially CHECK-TYPE, but we can't use that since

  ;; CHECK-TYPE doesn't evaluate the type argument.

  (loop

      (when (typep new-value (slot-definition-type slotd))

	(return nil))

      (setf new-value (lisp::check-type-error 'new-value

					      new-value

					      (slot-definition-type slotd)

					      nil)))

  (function-funcall (slot-definition-writer-function slotd) new-value object))



(defun slot-boundp-using-class-dfun (class object slotd)

pcl/rt/slot-type.lisp

+7 −1
Original line number Diff line number Diff line
@@ -27,7 +27,7 @@ 
;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH

;;; DAMAGE.



(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/slot-type.lisp,v 1.2 2003/03/22 16:15:14 gerd Exp $")

(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/slot-type.lisp,v 1.3 2008/12/02 18:18:34 rtoy Rel $")

 

(in-package "PCL-TEST")
@@ -74,3 +74,9 @@ 
      (values r (typep c 'error)))

  nil t)



(deftest slot-type.4

    (multiple-value-bind (r c)

	(ignore-errors

	  (setf (slot-value (make-instance 'stype) 'a) "string"))

      (values r (typep c 'error)))

  nil t)