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 (defpackage "MOP-18"
  17   (:use "CL" "SB-MOP"))
  18
  19 (in-package "MOP-18")
  20
  21 (defvar *in-reinitialize-instance* nil)
  22
  23 (defvar *finalized-class* nil)
  24
  25 (defclass test-standard-class (standard-class) ())
  26
  27 (defmethod validate-superclass
  28     ((class test-standard-class) (superclass standard-class))
  29   t)
  30
  31 (defmethod finalize-inheritance :before ((class test-standard-class))
  32   (when *in-reinitialize-instance*
  33     (setf *finalized-class* class)))
  34
  35 (defmethod reinitialize-instance :around
  36     ((class test-standard-class) &key &allow-other-keys)
  37   (let ((*in-reinitialize-instance* t))
  38     (call-next-method)))
  39
  40 (defclass test-standard-object () ((slot))
  41   (:metaclass test-standard-class))
  42
  43 (unless (class-finalized-p (find-class 'test-standard-object))
  44   (finalize-inheritance (find-class 'test-standard-object)))
  45
  46 (assert (class-slots (find-class 'test-standard-object)))
  47 (assert (null *finalized-class*))
  48 (reinitialize-instance (find-class 'test-standard-object) :direct-slots nil)
  49 (assert (eq *finalized-class* (find-class 'test-standard-object)))
  50 (assert (null (class-slots (find-class 'test-standard-object))))
  51 \f
  52 (defclass test-funcallable-standard-class (funcallable-standard-class) ())
  53
  54 (defmethod validate-superclass
  55     ((class test-funcallable-standard-class)
  56      (superclass funcallable-standard-class))
  57   t)
  58
  59 (defmethod finalize-inheritance :before
  60     ((class test-funcallable-standard-class))
  61   (when *in-reinitialize-instance*
  62     (setf *finalized-class* class)))
  63
  64 (defmethod reinitialize-instance :around
  65     ((class test-funcallable-standard-class) &key &allow-other-keys)
  66   (let ((*in-reinitialize-instance* t))
  67     (call-next-method)))
  68
  69 (defclass test-funcallable-standard-object () ((slot))
  70   (:metaclass test-funcallable-standard-class))
  71
  72 (unless (class-finalized-p (find-class 'test-funcallable-standard-object))
  73   (finalize-inheritance (find-class 'test-funcallable-standard-object)))
  74
  75 (assert (class-slots (find-class 'test-funcallable-standard-object)))
  76 (assert (eq *finalized-class* (find-class 'test-standard-object)))
  77 (reinitialize-instance (find-class 'test-funcallable-standard-object)
  78                        :direct-slots nil)
  79 (assert (eq *finalized-class* (find-class 'test-funcallable-standard-object)))
  80 (assert (null (class-slots (find-class 'test-funcallable-standard-object))))