tests/mop-29.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 ;;; a test that metaclasses can be instantiated even if there are
  15 ;;; applicable methods for SLOT-VALUE-USING-CLASS with specialized
  16 ;;; arguments that invoke slot readers.  (Previously the PV
  17 ;;; optimization for slot readers caused the new class's wrapper and
  18 ;;; effective slot definitions to be available during class
  19 ;;; finalization)
  20
  21 (defclass my-class (standard-class)
  22   ())
  23
  24 (defmethod sb-mop:validate-superclass ((class my-class) (super-class standard-class))
  25   t)
  26
  27 (defvar *foo*)
  28
  29 ;;; the specialization of OBJECT here triggers the PV optimization;
  30 ;;; with an unspecialized argument, the SLOT-VALUE is not optimized.
  31 (defmethod sb-mop:slot-value-using-class
  32     ((class my-class) (object standard-object) eslotd)
  33   (if *foo*
  34       (setf (slot-value object 'id) 42)
  35       (call-next-method)))
  36
  37 (defclass my-object ()
  38   ((id :type integer :reader id-of))
  39   (:metaclass my-class))
  40
  41 ;;; the first patch failed on code like this, because the STD-P field
  42 ;;; of the accessor information was also computed lazily, but it is
  43 ;;; needed in order to real with accessor cache misses.
  44 (defun test-global-accessors ()
  45   (let ((object (make-instance 'my-object)))
  46     (setf (slot-value object 'id) 13)
  47     (let ((*foo* nil))
  48       (assert (= (id-of object) 13))
  49       (assert (= (slot-value object 'id) 13)))
  50     (let ((*foo* t))
  51       (assert (= (id-of object) 42))
  52       (assert (= (slot-value object 'id) 42)))
  53     (let ((*foo* nil))
  54       (assert (= (id-of object) 42))
  55       (assert (= (slot-value object 'id) 42)))))
  56 (compile 'test-global-accessors)
  57
  58 (with-test (:name (:mop-29))
  59   (test-global-accessors))