+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; a test that metaclasses can be instantiated even if there are
+;;; applicable methods for SLOT-VALUE-USING-CLASS with specialized
+;;; arguments that invoke slot readers. (Previously the PV
+;;; optimization for slot readers caused the new class's wrapper and
+;;; effective slot definitions to be available during class
+;;; finalization)
+
+(load "assertoid.lisp")
+
+(defpackage "MOP-29"
+ (:use "CL" "SB-MOP"))
+
+(in-package "MOP-29")
+
+(defclass my-class (standard-class)
+ ())
+(defmethod validate-superclass ((class my-class) (super-class standard-class))
+ t)
+(defvar *foo*)
+;;; the specialization of OBJECT here triggers the PV optimization;
+;;; with an unspecialized argument, the SLOT-VALUE is not optimized.
+(defmethod slot-value-using-class
+ ((class my-class) (object standard-object) eslotd)
+ (if *foo*
+ (setf (slot-value object 'id) 42)
+ (call-next-method)))
+(defclass my-object ()
+ ((id :type integer :reader id-of))
+ (:metaclass my-class))
+
+;;; the first patch failed on code like this, because the STD-P field
+;;; of the accessor information was also computed lazily, but it is
+;;; needed in order to real with accessor cache misses.
+(defun test-global-accessors ()
+ (let ((object (make-instance 'my-object)))
+ (setf (slot-value object 'id) 13)
+ (let ((*foo* nil))
+ (assert (= (id-of object) 13))
+ (assert (= (slot-value object 'id) 13)))
+ (let ((*foo* t))
+ (assert (= (id-of object) 42))
+ (assert (= (slot-value object 'id) 42)))
+ (let ((*foo* nil))
+ (assert (= (id-of object) 42))
+ (assert (= (slot-value object 'id) 42)))))
+(compile 'test-global-accessors)
+(test-global-accessors)