tests/mop-25.impure.lisp

   1 ;;;; miscellaneous side-effectful tests of the MOP
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 ;;; be sure that the :FUNCTION initarg to initialize methods overrides
  15 ;;; any system-provided function.
  16
  17 (defclass typechecking-reader-method (standard-reader-method)
  18   ())
  19
  20 (defmethod initialize-instance
  21     ((method typechecking-reader-method) &rest initargs &key slot-definition)
  22   (let ((name (sb-mop:slot-definition-name slot-definition))
  23         (type (sb-mop:slot-definition-type slot-definition)))
  24     (apply #'call-next-method method
  25            :function #'(lambda (args next-methods)
  26                          (declare (ignore next-methods))
  27                          (apply #'(lambda (instance)
  28                                     (let ((value (slot-value instance name)))
  29                                       (unless (typep value type)
  30                                         (error "Slot ~S of ~S is not of type ~S: ~S"
  31                                                name instance type value))
  32                                       value))
  33                                 args))
  34            initargs)))
  35 (defclass typechecking-reader-class (standard-class)
  36   ())
  37
  38 (defmethod sb-mop:validate-superclass ((c1 typechecking-reader-class) (c2 standard-class))
  39   t)
  40
  41 (defmethod reader-method-class
  42     ((class typechecking-reader-class) direct-slot &rest args)
  43   (declare (ignore args))
  44   (find-class 'typechecking-reader-method))
  45
  46 (defclass testclass25 ()
  47   ((pair :type (cons symbol (cons symbol null)) :initarg :pair :accessor testclass25-pair))
  48   (:metaclass typechecking-reader-class))
  49
  50 (with-test (:name (:mop-24))
  51   (let ((p (list 'abc 'def))
  52         (x (make-instance 'testclass25)))
  53     (assert-no-signal (make-instance 'testclass25 :pair '(seventeen 17)))
  54     (assert-no-signal (setf (testclass25-pair x) p))
  55     (assert-no-signal (setf (second p) 456))
  56     (assert-no-signal (testclass25-pair x))
  57     (assert-no-signal (slot-value x 'pair))))