tests/mop-18.impure-cload.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 ;;; this file tests the protocol for Reinitialization of Class Metaobjects
  15
  16 (defvar *in-reinitialize-instance* nil)
  17
  18 (defvar *finalized-class* nil)
  19
  20 (defclass test-standard-class (standard-class) ())
  21
  22 (defmethod sb-mop:validate-superclass
  23     ((class test-standard-class) (superclass standard-class))
  24   t)
  25
  26 (defmethod sb-mop:finalize-inheritance :before ((class test-standard-class))
  27   (when *in-reinitialize-instance*
  28     (setf *finalized-class* class)))
  29
  30 (defmethod reinitialize-instance :around
  31     ((class test-standard-class) &key &allow-other-keys)
  32   (let ((*in-reinitialize-instance* t))
  33     (call-next-method)))
  34
  35 (defclass test-standard-object () ((slot))
  36   (:metaclass test-standard-class))
  37
  38 (unless (sb-mop:class-finalized-p (find-class 'test-standard-object))
  39   (sb-mop:finalize-inheritance (find-class 'test-standard-object)))
  40
  41 (with-test (:name (:mop-18 1))
  42   (assert (sb-mop:class-slots (find-class 'test-standard-object)))
  43   (assert (null *finalized-class*))
  44   (reinitialize-instance (find-class 'test-standard-object) :direct-slots nil)
  45   (assert (eq *finalized-class* (find-class 'test-standard-object)))
  46   (assert (null (sb-mop:class-slots (find-class 'test-standard-object)))))
  47 \f
  48 (defclass test-funcallable-standard-class (sb-mop:funcallable-standard-class)
  49   ())
  50
  51 (defmethod sb-mop:validate-superclass
  52     ((class test-funcallable-standard-class)
  53      (superclass sb-mop:funcallable-standard-class))
  54   t)
  55
  56 (defmethod sb-mop:finalize-inheritance :before
  57     ((class test-funcallable-standard-class))
  58   (when *in-reinitialize-instance*
  59     (setf *finalized-class* class)))
  60
  61 (defmethod reinitialize-instance :around
  62     ((class test-funcallable-standard-class) &key &allow-other-keys)
  63   (let ((*in-reinitialize-instance* t))
  64     (call-next-method)))
  65
  66 (defclass test-funcallable-standard-object () ((slot))
  67   (:metaclass test-funcallable-standard-class))
  68
  69 (unless (sb-mop:class-finalized-p (find-class 'test-funcallable-standard-object))
  70   (sb-mop:finalize-inheritance (find-class 'test-funcallable-standard-object)))
  71
  72 (with-test (:name (:mop-18 2))
  73   (assert (sb-mop:class-slots (find-class 'test-funcallable-standard-object)))
  74   (assert (eq *finalized-class* (find-class 'test-standard-object)))
  75   (reinitialize-instance (find-class 'test-funcallable-standard-object)
  76                          :direct-slots nil)
  77   (assert (eq *finalized-class* (find-class 'test-funcallable-standard-object)))
  78   (assert (null (sb-mop:class-slots (find-class 'test-funcallable-standard-object)))))