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 (load "assertoid.lisp")
  22
  23 (defpackage "MOP-29"
  24   (:use "CL" "SB-MOP"))
  25
  26 (in-package "MOP-29")
  27
  28 (defclass my-class (standard-class)
  29   ())
  30 (defmethod validate-superclass ((class my-class) (super-class standard-class))
  31   t)
  32 (defvar *foo*)
  33 ;;; the specialization of OBJECT here triggers the PV optimization;
  34 ;;; with an unspecialized argument, the SLOT-VALUE is not optimized.
  35 (defmethod slot-value-using-class
  36     ((class my-class) (object standard-object) eslotd)
  37   (if *foo*
  38       (setf (slot-value object 'id) 42)
  39       (call-next-method)))
  40 (defclass my-object ()
  41   ((id :type integer :reader id-of))
  42   (:metaclass my-class))
  43
  44 ;;; the first patch failed on code like this, because the STD-P field
  45 ;;; of the accessor information was also computed lazily, but it is
  46 ;;; needed in order to real with accessor cache misses.
  47 (defun test-global-accessors ()
  48   (let ((object (make-instance 'my-object)))
  49     (setf (slot-value object 'id) 13)
  50     (let ((*foo* nil))
  51       (assert (= (id-of object) 13))
  52       (assert (= (slot-value object 'id) 13)))
  53     (let ((*foo* t))
  54       (assert (= (id-of object) 42))
  55       (assert (= (slot-value object 'id) 42)))
  56     (let ((*foo* nil))
  57       (assert (= (id-of object) 42))
  58       (assert (= (slot-value object 'id) 42)))))
  59 (compile 'test-global-accessors)
  60 (test-global-accessors)