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

Last change on this file since 9045 was 9045, checked in by gz, 12 years ago

Assorted cleanup:

In infrastructure:

  • add *test-verbose* and :verbose argument to do-test and do-tests. Avoid random output if false, only show failures
  • muffle-wawrnings and/or bind *suppress-compiler-warnings* in some tests that unavoidably generate them (mainly with duplicate typecase/case clauses)
  • Add record-source-file for tests so meta-. can find them
  • If *catch-errors* (or the :catch-errors arg) is :break, enter a breakloop when catch an error
  • Make test fns created by *compile-tests* have names, so can find them in backtraces
  • fix misc compiler warnings
  • Fixed cases of duplicate test numbers
  • Disable note :make-condition-with-compound-name for openmcl.

In tests themselves:

I commented out the following tests with #+bogus-test, because they just seemed wrong to me:

lambda.47
lambda.50
upgraded-array-element-type.8
upgraded-array-element-type.nil.1
pathname-match-p.5
load.17
load.18
macrolet.47
ctypecase.15

In addition, I commented out the following tests with #+bogus-test because I was too lazy to make a note
for "doesn't signal underflow":

exp.error.8 exp.error.9 exp.error.10 exp.error.11 expt.error.8 expt.error.9 expt.error.10 expt.error.11

Finally, I entered bug reports in trac, and then commented out the tests
below with #+known-bug-NNN, where nnn is the ticket number in trac:

ticket#268: encode-universal-time.3 encode-universal-time.3.1
ticket#269: macrolet.36
ticket#270: values.20 values.21
ticket#271: defclass.error.13 defclass.error.22
ticket#272: phase.10 phase.12 asin.5 asin.6 asin.8
ticket#273: phase.18 phase.19 acos.8
ticket#274: exp.error.4 exp.error.5 exp.error.6 exp.error.7
ticket#275: car.error.2 cdr.error.2
ticket#276: map.error.11
ticket#277: subtypep.cons.43
ticket#278: subtypep-function.3
ticket#279: subtypep-complex.8
ticket#280: open.output.19 open.io.19 file-position.8 file-length.4 file-length.5 read-byte.4 stream-element-type.2 stream-element-type.3
ticket#281: open.65
ticket#288: set-syntax-from-char.sharp.1

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.