File: mop-18.impure-cload.lisp

package info (click to toggle)
sbcl 1%3A0.9.16.0-1
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 19,960 kB
  • ctags: 16,537
  • sloc: lisp: 231,164; ansic: 19,558; asm: 2,539; sh: 1,925; makefile: 308
file content (80 lines) | stat: -rw-r--r-- 2,846 bytes parent folder | download | duplicates (6)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
;;;; 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.

;;; this file tests the protocol for Reinitialization of Class Metaobjects

(defpackage "MOP-18"
  (:use "CL" "SB-MOP"))

(in-package "MOP-18")

(defvar *in-reinitialize-instance* nil)

(defvar *finalized-class* nil)

(defclass test-standard-class (standard-class) ())

(defmethod validate-superclass
    ((class test-standard-class) (superclass standard-class))
  t)

(defmethod finalize-inheritance :before ((class test-standard-class))
  (when *in-reinitialize-instance*
    (setf *finalized-class* class)))

(defmethod reinitialize-instance :around
    ((class test-standard-class) &key &allow-other-keys)
  (let ((*in-reinitialize-instance* t))
    (call-next-method)))

(defclass test-standard-object () ((slot))
  (:metaclass test-standard-class))

(unless (class-finalized-p (find-class 'test-standard-object))
  (finalize-inheritance (find-class 'test-standard-object)))

(assert (class-slots (find-class 'test-standard-object)))
(assert (null *finalized-class*))
(reinitialize-instance (find-class 'test-standard-object) :direct-slots nil)
(assert (eq *finalized-class* (find-class 'test-standard-object)))
(assert (null (class-slots (find-class 'test-standard-object))))

(defclass test-funcallable-standard-class (funcallable-standard-class) ())

(defmethod validate-superclass
    ((class test-funcallable-standard-class)
     (superclass funcallable-standard-class))
  t)

(defmethod finalize-inheritance :before
    ((class test-funcallable-standard-class))
  (when *in-reinitialize-instance*
    (setf *finalized-class* class)))

(defmethod reinitialize-instance :around
    ((class test-funcallable-standard-class) &key &allow-other-keys)
  (let ((*in-reinitialize-instance* t))
    (call-next-method)))

(defclass test-funcallable-standard-object () ((slot))
  (:metaclass test-funcallable-standard-class))

(unless (class-finalized-p (find-class 'test-funcallable-standard-object))
  (finalize-inheritance (find-class 'test-funcallable-standard-object)))

(assert (class-slots (find-class 'test-funcallable-standard-object)))
(assert (eq *finalized-class* (find-class 'test-standard-object)))
(reinitialize-instance (find-class 'test-funcallable-standard-object)
                       :direct-slots nil)
(assert (eq *finalized-class* (find-class 'test-funcallable-standard-object)))
(assert (null (class-slots (find-class 'test-funcallable-standard-object))))