tests/mop-31.impure.lisp

   1 ;;;; CHANGE-CLASS, obsolete instances, and methods on SLOT-VALUE-USING-CLASS
   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 (defclass metaclass (sb-mop:standard-class) ())
  15
  16 (defmethod sb-mop:validate-superclass ((class metaclass) (superclass t))
  17   NIL)
  18
  19 (defmethod sb-mop:validate-superclass ((class standard-class) (superclass metaclass))
  20   T)
  21
  22 (defmethod sb-mop:validate-superclass ((class metaclass) (superclass standard-class))
  23   T)
  24
  25 (defmethod sb-mop:validate-superclass ((class metaclass) (superclass metaclass))
  26   T)
  27
  28 (defmethod sb-mop:direct-slot-definition-class ((class metaclass) &rest initargs)
  29   (declare (ignore initargs))
  30   (find-class 'sb-mop:standard-direct-slot-definition))
  31
  32 (defmethod sb-mop:effective-slot-definition-class ((class metaclass) &rest initargs)
  33   (declare (ignore initargs))
  34   (find-class 'sb-mop:standard-effective-slot-definition))
  35
  36 (defmethod sb-mop:slot-value-using-class ((class metaclass) object slot)
  37   (if (eq 'test (sb-mop:slot-definition-name slot))
  38       (* 2 (call-next-method))
  39       (call-next-method)))
  40
  41 (defmethod (setf sb-mop:slot-value-using-class) (value (class metaclass) object slot)
  42   (if (eq 'test (sb-mop:slot-definition-name slot))
  43       (call-next-method (/ value 2) class object slot)
  44       (call-next-method)))
  45
  46 (defclass stdclass ()
  47   ((test :initform 2))
  48   (:metaclass metaclass))
  49
  50 (let ((a (make-instance 'stdclass)))
  51   (assert (= 2 (slot-value a 'test)))
  52   (change-class a 'stdclass)
  53   (assert (= 2 (slot-value a 'test))))
  54
  55 ;;; check obsolete instance handling
  56 (defvar *a* (make-instance 'stdclass))
  57
  58 (defclass stdclass ()
  59   ((test :initform 2)
  60    (newtest :initform 4))
  61   (:metaclass metaclass))
  62
  63 (assert (= 2 (slot-value *a* 'test)))
  64 (assert (= 4 (slot-value *a* 'newtest)))