1.0.19.4: recursive restart computation
[sbcl/pkhuong.git] / tests / mop-2.impure-cload.lisp
bloba3d7bc8ae442a62ea442ac53bd0fc7fbba8e10cd
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 ;;;; Note that the MOP is not in an entirely supported state.
15 ;;;; However, this seems a good a way as any of ensuring that we have
16 ;;;; no regressions.
18 ;;; This is basically the DYNAMIC-SLOT-CLASS example from AMOP, with
19 ;;; fixups for running in the full MOP rather than closette -- SLOTDs
20 ;;; instead of slot-names, and so on -- and :allocation :dynamic for
21 ;;; dynamic slots.
23 (untrace)
25 (defpackage "TEST" (:use "CL" "SB-MOP"))
26 (in-package "TEST")
28 (defclass dynamic-slot-class (standard-class) ())
30 (defmethod validate-superclass
31 ((class dynamic-slot-class) (super standard-class))
34 (defun dynamic-slot-p (slot)
35 (eq (slot-definition-allocation slot) :dynamic))
37 (let ((table (make-hash-table)))
39 (defun allocate-table-entry (instance)
40 (setf (gethash instance table) ()))
42 (defun read-dynamic-slot-value (instance slot-name)
43 (let* ((alist (gethash instance table))
44 (entry (assoc slot-name alist)))
45 (if (null entry)
46 (error "slot ~S unbound in ~S" slot-name instance)
47 (cdr entry))))
49 (defun write-dynamic-slot-value (new-value instance slot-name)
50 (let* ((alist (gethash instance table))
51 (entry (assoc slot-name alist)))
52 (if (null entry)
53 (push `(,slot-name . ,new-value)
54 (gethash instance table))
55 (setf (cdr entry) new-value))
56 new-value))
58 (defun dynamic-slot-boundp (instance slot-name)
59 (let* ((alist (gethash instance table))
60 (entry (assoc slot-name alist)))
61 (not (null entry))))
63 (defun dynamic-slot-makunbound (instance slot-name)
64 (let* ((alist (gethash instance table))
65 (entry (assoc slot-name alist)))
66 (unless (null entry)
67 (setf (gethash instance table) (delete entry alist))))
68 instance)
72 (defmethod allocate-instance ((class dynamic-slot-class) &key)
73 (let ((instance (call-next-method)))
74 (allocate-table-entry instance)
75 instance))
77 (defmethod slot-value-using-class ((class dynamic-slot-class)
78 instance slotd)
79 (let ((slot (find slotd (class-slots class))))
80 (if (and slot (dynamic-slot-p slot))
81 (read-dynamic-slot-value instance (slot-definition-name slotd))
82 (call-next-method))))
84 (defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
85 instance slotd)
86 (let ((slot (find slotd (class-slots class))))
87 (if (and slot (dynamic-slot-p slot))
88 (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
89 (call-next-method))))
91 (defmethod slot-boundp-using-class ((class dynamic-slot-class)
92 instance slotd)
93 (let ((slot (find slotd (class-slots class))))
94 (if (and slot (dynamic-slot-p slot))
95 (dynamic-slot-boundp instance (slot-definition-name slotd))
96 (call-next-method))))
98 (defmethod slot-makunbound-using-class ((class dynamic-slot-class)
99 instance slotd)
100 (let ((slot (find slotd (class-slots class))))
101 (if (and slot (dynamic-slot-p slot))
102 (dynamic-slot-makunbound instance (slot-definition-name slotd))
103 (call-next-method))))
105 (defclass test-class-1 ()
106 ((slot1 :initarg :slot1 :allocation :dynamic)
107 (slot2 :initarg :slot2 :initform nil))
108 (:metaclass dynamic-slot-class))
110 (defclass test-class-2 (test-class-1)
111 ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
112 (slot3 :initarg :slot3))
113 (:metaclass dynamic-slot-class))
115 (defvar *one* (make-instance 'test-class-1))
116 (defvar *two* (make-instance 'test-class-2 :slot3 1))
118 (assert (not (slot-boundp *one* 'slot1)))
119 (assert (null (slot-value *one* 'slot2)))
120 (assert (eq t (slot-value *two* 'slot2)))
121 (assert (= 1 (slot-value *two* 'slot3)))
123 ;;; breakage observed by R. Mattes sbcl-help 2004-09-16, caused by
124 ;;; overconservatism in accessing a class's precedence list deep in
125 ;;; the bowels of COMPUTE-APPLICABLE-METHODS, during the process of
126 ;;; finalizing a class.
127 (defclass dynamic-slot-subclass (dynamic-slot-class) ())
129 (defmethod slot-value-using-class ((class dynamic-slot-subclass)
130 instance slotd)
131 (let ((slot (find slotd (class-slots class))))
132 (if (and slot (dynamic-slot-p slot))
133 (read-dynamic-slot-value instance (slot-definition-name slotd))
134 (call-next-method))))
136 (defmethod (setf slot-value-using-class) (new-value
137 (class dynamic-slot-subclass)
138 instance slotd)
139 (let ((slot (find slotd (class-slots class))))
140 (if (and slot (dynamic-slot-p slot))
141 (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
142 (call-next-method))))
144 (defmethod slot-boundp-using-class ((class dynamic-slot-subclass)
145 instance slotd)
146 (let ((slot (find slotd (class-slots class))))
147 (if (and slot (dynamic-slot-p slot))
148 (dynamic-slot-boundp instance (slot-definition-name slotd))
149 (call-next-method))))
151 (defclass test-class-3 (test-class-1)
152 ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
153 (slot3 :initarg :slot3))
154 (:metaclass dynamic-slot-subclass))
156 (defvar *three* (make-instance 'test-class-3 :slot3 3))
157 (assert (not (slot-boundp *three* 'slot1)))
158 (assert (eq (slot-value *three* 'slot2) t))
159 (assert (= (slot-value *three* 'slot3) 3))