Parse raw slot data when printing structures in LDB
[sbcl.git] / tests / mop-18.impure-cload.lisp
blob9c298de05bf78fb87999d5a365dfeb8b0ac20cfd
1 ;;;; miscellaneous side-effectful tests of the MOP
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.
14 ;;; this file tests the protocol for Reinitialization of Class Metaobjects
16 (defpackage "MOP-18"
17 (:use "CL" "SB-MOP"))
19 (in-package "MOP-18")
21 (defvar *in-reinitialize-instance* nil)
23 (defvar *finalized-class* nil)
25 (defclass test-standard-class (standard-class) ())
27 (defmethod validate-superclass
28 ((class test-standard-class) (superclass standard-class))
31 (defmethod finalize-inheritance :before ((class test-standard-class))
32 (when *in-reinitialize-instance*
33 (setf *finalized-class* class)))
35 (defmethod reinitialize-instance :around
36 ((class test-standard-class) &key &allow-other-keys)
37 (let ((*in-reinitialize-instance* t))
38 (call-next-method)))
40 (defclass test-standard-object () ((slot))
41 (:metaclass test-standard-class))
43 (unless (class-finalized-p (find-class 'test-standard-object))
44 (finalize-inheritance (find-class 'test-standard-object)))
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))))
52 (defclass test-funcallable-standard-class (funcallable-standard-class) ())
54 (defmethod validate-superclass
55 ((class test-funcallable-standard-class)
56 (superclass funcallable-standard-class))
59 (defmethod finalize-inheritance :before
60 ((class test-funcallable-standard-class))
61 (when *in-reinitialize-instance*
62 (setf *finalized-class* class)))
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)))
69 (defclass test-funcallable-standard-object () ((slot))
70 (:metaclass test-funcallable-standard-class))
72 (unless (class-finalized-p (find-class 'test-funcallable-standard-object))
73 (finalize-inheritance (find-class 'test-funcallable-standard-object)))
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))))