source: trunk/source/tests/ansi-tests/defclass-aux.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 10.1 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Mon Mar 24 03:40:24 2003
4;;;; Contains: Auxiliary functions for testing CLOS
5
6(in-package :cl-test)
7
8(defun make-defclass-test-name (&rest args)
9  (intern (apply #'concatenate 'string (mapcar #'string args))
10          (find-package :cl-test)))
11
12(defparameter *defclass-slot-readers* nil)
13(defparameter *defclass-slot-writers* nil)
14(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  ;; Internal fields
24  (preds nil :type list)
25  (succs nil :type list)
26  (count 0 :type integer)
27  (index nil)
28  (min-pred-index 1000000)
29  )
30
31(defstruct my-slot
32  (name nil :type symbol)
33  (has-initform nil :type boolean)
34  initform
35  (initargs nil :type list)
36  (documentation nil :type (or null string))
37  (readers nil :type list)
38  (writers nil :type list)
39  (accessors nil :type list)
40  (allocation :instance :type (member :instance :class))
41  (type t)
42  )
43
44(defparameter *my-classes* (make-hash-table)
45  "Hash table mapping names of classes defined using DEFCLASS-WITH-TESTS
46   to their my-class objects.")
47
48(defun find-my-class (class-name)
49  (gethash class-name *my-classes*))
50
51;;; This macro will assume that all the superclasses have already
52;;; been defined.  Tests will be written with defclass itself
53;;; to test forward referenced superclasses
54
55(defmacro defclass-with-tests
56  (&whole args
57          class-name superclasses slot-specifiers
58          &rest class-options)
59
60  (assert (typep class-name '(and (not null) symbol)))
61  (assert (listp superclasses))
62  (assert (every #'(lambda (x) (typep x '(and (not null) symbol)))
63                 superclasses))
64  (assert (listp slot-specifiers))
65  (assert (every #'(lambda (s)
66                     (or (symbolp s) (and (consp s) (symbolp (car s)))))
67                 slot-specifiers))
68  (assert (every #'(lambda (x)
69                     (and (consp x)
70                          (member (car x) '(:default-initargs
71                                            :documentation
72                                            :metaclass))))
73                 class-options))
74  (assert (eql (length class-options)
75               (length (remove-duplicates class-options))))
76
77  (let* ((default-initargs (rest (assoc :default-initargs class-options)))
78         (metaclass (or (second (assoc :metaclass class-options))
79                        'standard-class))
80         (doc (second (assoc :documentation class-options)))
81         (slot-names
82          (loop for slot-spec in slot-specifiers
83                collect (cond
84                         ((symbolp slot-spec) slot-spec)
85                         (t (assert (consp slot-spec))
86                            (assert (symbolp (car slot-spec)))
87                            (car slot-spec)))))
88         (slot-options
89          (loop for slot-spec in slot-specifiers
90                collect (if (consp slot-spec)
91                            (cdr slot-spec)
92                          nil)))
93         (readers
94          (loop for slot-option in slot-options
95                append (collect-properties slot-option :reader)))
96         (writers
97          (loop for slot-option in slot-options
98                append (collect-properties slot-option :writer)))
99         (accessors
100          (loop for slot-option in slot-options
101                append (collect-properties slot-option :accessor)))
102         (allocations
103          (loop for slot-option in slot-options
104                collect (or (get slot-option :allocation)
105                            :instance)))
106         (initargs
107          (loop for slot-option in slot-options
108                collect (collect-properties slot-option :initarg)))
109         (types
110          (loop for slot-option in slot-options
111                collect (collect-properties slot-option :type)))
112         (initforms
113          (loop for slot-option in slot-options
114                collect (collect-properties slot-option :initform)))
115         (class-var-name
116          (intern (concatenate 'string "*CLASS-" (symbol-name class-name)
117                               "-RETURNED-BY-DEFCLASS*")
118                  (find-package :cl-test)))
119         )
120
121    (declare (ignorable readers writers accessors allocations
122                        initargs types initforms default-initargs
123                        doc))
124
125    (assert (loop for e in types always (< (length e) 2)))
126    (assert (loop for e in initforms always (< (length e) 2)))
127
128    (setf *defclass-slot-readers* (append readers *defclass-slot-readers*))
129    (setf *defclass-slot-writers* (append writers *defclass-slot-writers*))
130    (setf *defclass-slot-accessors*
131          (append accessors *defclass-slot-accessors*))
132
133    ;;; Store away information about the class and its slots
134    ;;; in a my-class object and associated my-slot objects.
135   
136    (let* ((my-slots
137           (loop for name in slot-names
138                 for slot-option in slot-options
139                 for readers = (collect-properties slot-option :reader)
140                 for writers = (collect-properties slot-option :writer)
141                 for accessors = (collect-properties slot-option :accessor)
142                 for documentation = (getf slot-option :documentation)
143                 for initarg-list in initargs
144                 for type-list in types
145                 for initform-list in initforms
146                 for allocation in allocations
147                 collect
148                 (make-my-slot
149                  :name name
150                  :has-initform (notnot initform-list)
151                  :initform (first initform-list)
152                  :documentation documentation
153                  :readers readers
154                  :writers writers
155                  :accessors accessors
156                  :type (if type-list (first type-list) t)
157                  )))
158          (my-class-obj
159           (make-my-class :name class-name
160                          :direct-superclass-names superclasses
161                          :default-initargs default-initargs
162                          :documentation doc
163                          :metaclass metaclass
164                          :slots my-slots)))
165      (setf (gethash class-name *my-classes*) my-class-obj))
166
167    `(progn
168       (declaim (special ,class-var-name))
169       
170       (report-and-ignore-errors (setq ,class-var-name
171                                       (defclass ,@(cdr args))))
172
173       (deftest ,(make-defclass-test-name class-name "-DEFCLASS-RETURNS-CLASS")
174         (eqt (find-class ',class-name) ,class-var-name)
175         t)
176
177       (deftest ,(make-defclass-test-name class-name
178                                          "-IS-IN-ITS-METACLASS")
179         (notnot-mv (typep (find-class ',class-name) ',metaclass))
180         t)
181
182       ,@(when (eq metaclass 'standard-class)
183           `((deftest ,(make-defclass-test-name class-name
184                                                "S-ARE-STANDARD-OBJECTS")
185               (subtypep* ',class-name 'standard-object)
186               t t)))
187
188       ,@(loop for slot-name in slot-names
189               collect
190               `(deftest ,(make-defclass-test-name class-name
191                                                   "-HAS-SLOT-NAMED-"
192                                                   slot-name)
193                  (notnot-mv (slot-exists-p (make-instance ',class-name)
194                                            ',slot-name))
195                  t))
196
197       (deftest ,(make-defclass-test-name class-name
198                                          "-ALLOCATE-INSTANCE")
199         (defclass-allocate-instance-test ',class-name ',slot-names)
200         nil)
201
202       )))
203
204(defun defclass-allocate-instance-test (class-name slot-names)
205  (let* ((class (find-class class-name))
206         (instance (allocate-instance class)))
207    (append
208     (unless (eql (class-of instance) class)
209       (list (list 'not-instance-of class-name)))
210     (loop for slot in slot-names
211           when (slot-boundp instance slot)
212           collect (list 'is-bound slot))
213     (loop for slot in slot-names
214           unless (equal (multiple-value-list
215                           (notnot-mv (slot-exists-p instance slot)))
216                          '(t))
217           collect (list 'does-not-exist slot))
218     (let ((bad-slot '#:foo))
219       (when (slot-exists-p instance bad-slot)
220         (list (list 'should-not-exist bad-slot))))
221     )))
222 
223(defmacro generate-slot-tests ()
224  "Generate generic tests from the read/writer/accessor functions
225   for slots from defclass-with-tests."
226  (let ((funs (remove-duplicates
227               (append *defclass-slot-readers*
228                       *defclass-slot-writers*
229                       *defclass-slot-accessors*))))
230    `(progn
231       (deftest class-readers/writers/accessors-are-generic-functions
232         (loop for sym in ',funs
233               unless (typep (symbol-function sym) 'generic-function)
234               collect sym)
235         nil)
236       
237       (deftest class-accessors-have-generic-setf-functions
238         (append
239          ,@(loop for sym in *defclass-slot-accessors*
240                  collect
241                  `(and (not (typep (function (setf ,sym))
242                                    'generic-function))
243                        '(,sym))))
244         nil))))
245
246(defun my-compute-class-precedence-list (class-name)
247  "Compute the class precdence list for classes defined using
248   DEFCLASS-WITH-TESTS."
249  (let ((class-names nil)
250        (class-names-to-consider (list class-name))
251        classes)
252    ;; Find all classes
253    (loop
254     while class-names-to-consider
255     do (let ((name (pop class-names-to-consider)))
256          (unless (member name class-names)
257            (push name class-names)
258            (let ((my-class (find-my-class name)))
259              (assert my-class)
260              (setq class-names-to-consider
261                    (append (my-class-direct-superclass-names my-class)
262                            class-names-to-consider))))))
263    (setq class-names (reverse class-names))
264    (assert (eq class-name (first class-names)))
265    ;; class-names now contains class-name (which occurs first) and
266    ;; the names of all its superclasses except T
267    (setq classes (mapcar #'find-my-class class-names))
268    ;; Walk the classes and set the predecessor links in the
269    ;; class precedence DAG
270    (loop for c in classes
271          for dsns = (my-class-direct-superclass-names c)
272          do (let ((pred c))
273               (loop for superclass-name in dsns
274                     for superclass = (find-my-class superclass-name)
275                     do (push pred (my-class-preds superclass))
276                     do (pushnew superclass (my-class-succs pred))
277                     do (incf (my-class-count superclass))
278                     do (setq pred superclass))))
279    ;; The list candidates will contain all the classes
280    ;; for which the count is zero.  These are the candidates
281    ;; for selection as the next class in the class precedence list
282    (let ((candidates (loop for c in classes
283                            when (zerop (my-class-count c))
284                            collect c))
285          (n 0)
286          (result nil))
287      (assert (equal candidates (list (first classes))))
288      (loop
289       while candidates
290       do (let* ((next (first candidates))
291                 (min-pred-index (my-class-min-pred-index next)))
292            (loop
293             for c in (rest candidates)
294             for c-min-pred-index = (my-class-min-pred-index c)
295             do
296             (cond
297              ((< c-min-pred-index min-pred-index)
298               (setq next c
299                     min-pred-index c-min-pred-index))
300              (t (assert (not (= c-min-pred-index min-pred-index))))))
301            (setq candidates (remove next candidates))
302            (setf (my-class-index next) (incf n))
303            (push next result)
304            (loop
305             for succ in (my-class-succs next)
306             do (decf (my-class-count succ))
307             do (setf (my-class-min-pred-index succ)
308                      (min (my-class-min-pred-index succ)
309                           n))
310             do (when (zerop (my-class-count succ))
311                  (push succ candidates)))))
312      (assert (eql (length result) (length classes)))
313      (setq result (reverse result))
314      (mapcar #'my-class-name result))))
Note: See TracBrowser for help on using the repository browser.