13 |
(defparameter *defclass-slot-writers* nil) |
(defparameter *defclass-slot-writers* nil) |
14 |
(defparameter *defclass-slot-accessors* nil) |
(defparameter *defclass-slot-accessors* nil) |
15 |
|
|
16 |
|
(defstruct my-class |
17 |
|
(name nil :type symbol) |
18 |
|
(direct-superclass-names nil :type list) |
19 |
|
(slots nil :type list) |
20 |
|
(default-initargs nil :type list) |
21 |
|
(metaclass 'standard-class :type symbol) |
22 |
|
(documentation nil :type (or null string)) |
23 |
|
) |
24 |
|
|
25 |
|
(defstruct my-slot |
26 |
|
(name nil :type symbol) |
27 |
|
(has-initform nil :type boolean) |
28 |
|
initform |
29 |
|
(initargs nil :type list) |
30 |
|
(documentation nil :type (or null string)) |
31 |
|
(readers nil :type list) |
32 |
|
(writers nil :type list) |
33 |
|
(accessors nil :type list) |
34 |
|
(allocation :instance :type (member :instance :class)) |
35 |
|
(type t) |
36 |
|
) |
37 |
|
|
38 |
|
(defparameter *my-classes* (make-hash-table) |
39 |
|
"Hash table mapping names of classes defined using DEFCLASS-WITH-TESTS |
40 |
|
to their my-class objects.") |
41 |
|
|
42 |
|
(defun find-my-class (class-name) |
43 |
|
(gethash class-name *my-classes*)) |
44 |
|
|
45 |
(defmacro defclass-with-tests |
(defmacro defclass-with-tests |
46 |
(&whole args |
(&whole args |
47 |
class-name superclasses slot-specifiers |
class-name superclasses slot-specifiers |
64 |
(assert (eql (length class-options) |
(assert (eql (length class-options) |
65 |
(length (remove-duplicates class-options)))) |
(length (remove-duplicates class-options)))) |
66 |
|
|
67 |
(let* ((default-initargs (second (assoc :default-initargs class-options))) |
(let* ((default-initargs (rest (assoc :default-initargs class-options))) |
68 |
(metaclass (or (second (assoc :metaclass class-options)) |
(metaclass (or (second (assoc :metaclass class-options)) |
69 |
'standard-class)) |
'standard-class)) |
70 |
(doc (second (assoc :documentation class-options))) |
(doc (second (assoc :documentation class-options))) |
91 |
append (collect-properties slot-option :accessor))) |
append (collect-properties slot-option :accessor))) |
92 |
(allocations |
(allocations |
93 |
(loop for slot-option in slot-options |
(loop for slot-option in slot-options |
94 |
collect (or (get :allocation slot-option) |
collect (or (get slot-option :allocation) |
95 |
:instance))) |
:instance))) |
96 |
(initargs |
(initargs |
97 |
(loop for slot-option in slot-options |
(loop for slot-option in slot-options |
116 |
(setf *defclass-slot-accessors* |
(setf *defclass-slot-accessors* |
117 |
(append accessors *defclass-slot-accessors*)) |
(append accessors *defclass-slot-accessors*)) |
118 |
|
|
119 |
|
;;; Store away information about the class and its slots |
120 |
|
;;; in a my-class object and associated my-slot objects. |
121 |
|
|
122 |
|
(let* ((my-slots |
123 |
|
(loop for name in slot-names |
124 |
|
for slot-option in slot-options |
125 |
|
for readers = (collect-properties slot-option :reader) |
126 |
|
for writers = (collect-properties slot-option :writer) |
127 |
|
for accessors = (collect-properties slot-option :accessor) |
128 |
|
for documentation = (getf slot-option :documentation) |
129 |
|
for initarg-list in initargs |
130 |
|
for type-list in types |
131 |
|
for initform-list in initforms |
132 |
|
for allocation in allocations |
133 |
|
collect |
134 |
|
(make-my-slot |
135 |
|
:name name |
136 |
|
:has-initform (notnot initform-list) |
137 |
|
:initform (first initform-list) |
138 |
|
:documentation documentation |
139 |
|
:readers readers |
140 |
|
:writers writers |
141 |
|
:accessors accessors |
142 |
|
:type (if type-list (first type-list) t) |
143 |
|
))) |
144 |
|
(my-class-obj |
145 |
|
(make-my-class :name class-name |
146 |
|
:direct-superclass-names superclasses |
147 |
|
:default-initargs default-initargs |
148 |
|
:documentation doc |
149 |
|
:metaclass metaclass |
150 |
|
:slots my-slots))) |
151 |
|
(setf (gethash class-name *my-classes*) my-class-obj)) |
152 |
|
|
153 |
`(progn |
`(progn |
154 |
|
|
155 |
(eval-when (load eval compile) |
(eval-when (load eval compile) |
176 |
t)) |
t)) |
177 |
|
|
178 |
(deftest ,(make-defclass-test-name class-name |
(deftest ,(make-defclass-test-name class-name |
179 |
"-INSTANCES-CLASS-IS-THIS-ONE") |
"-ALLOCATE-INSTANCE") |
180 |
(let ((class (find-class ',class-name))) |
(defclass-allocate-instance-test ',class-name ',slot-names) |
181 |
(eqlt (class-of (allocate-instance class)) class)) |
nil) |
|
t) |
|
182 |
|
|
183 |
))) |
))) |
184 |
|
|
185 |
|
(defun defclass-allocate-instance-test (class-name slot-names) |
186 |
|
(let* ((class (find-class class-name)) |
187 |
|
(instance (allocate-instance class))) |
188 |
|
(append |
189 |
|
(unless (eql (class-of instance) class) |
190 |
|
(list (list 'not-instance-of class-name))) |
191 |
|
(loop for slot in slot-names |
192 |
|
when (slot-boundp instance slot) |
193 |
|
collect (list 'is-bound slot)) |
194 |
|
(loop for slot in slot-names |
195 |
|
(unless (equal (multiple-value-list |
196 |
|
(notnot-mv (slot-exists-p instance slot))) |
197 |
|
'(t)) |
198 |
|
(list 'does-not-exist slot))) |
199 |
|
(let ((bad-slot #:foo)) |
200 |
|
(when (slot-exists-p instance bad-slot) |
201 |
|
(list (list 'should-not-exist bad-slot)))) |
202 |
|
))) |
203 |
|
|
204 |
(defmacro generate-slot-tests () |
(defmacro generate-slot-tests () |
205 |
"Generate generic tests from the read/writer/accessor functions |
"Generate generic tests from the read/writer/accessor functions |
206 |
for slots from defclass-with-tests." |
for slots from defclass-with-tests." |
223 |
'generic-function)) |
'generic-function)) |
224 |
'(,sym)))) |
'(,sym)))) |
225 |
nil)))) |
nil)))) |
226 |
|
|
227 |
|
#| |
228 |
|
|
229 |
|
(defun compute-class-precedence-list (class-name) |
230 |
|
"Compute the class precdence list for classes defined using |
231 |
|
DEFCLASS-WITH-TESTS." |
232 |
|
(let ((classes nil) |
233 |
|
(classes-to-consider class-name)) |
234 |
|
;; Find all classes |
235 |
|
|
236 |
|
|# |
237 |
|
|