source: trunk/source/tests/ansi-tests/structure-00.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: 17.0 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat May  9 11:21:25 1998
4;;;; Contains: Common code for creating structure tests
5
6(in-package :cl-test)
7(declaim (optimize (safety 3)))
8
9(defun make-struct-test-name (structure-name n)
10  ;; (declare (type (or string symbol character) structure-name)
11  ;;  (type fixnum n))
12  (assert (typep structure-name '(or string symbol character)))
13  ;; (assert (typep n 'fixnum))
14  (setf structure-name (string structure-name))
15  (intern (concatenate 'string
16            structure-name
17            "/"
18            (princ-to-string n))))
19
20(defun make-struct-p-fn (structure-name)
21  (assert (typep structure-name '(or string symbol character)))
22  (setf structure-name (string structure-name))
23  (intern (concatenate 'string
24            structure-name
25            (string '#:-p))))
26
27(defun make-struct-copy-fn (structure-name)
28  (assert (typep structure-name '(or string symbol character)))
29  (setf structure-name (string structure-name))
30  (intern (concatenate 'string
31                       (string '#:copy-)
32                       structure-name)))
33
34(defun make-struct-field-fn (conc-name field-name)
35  "Make field accessor for a field in a structure"
36  (cond
37   ((null conc-name) field-name)
38   (t
39    (assert (typep conc-name '(or string symbol character)))
40    (assert (typep field-name '(or string symbol character)))
41    (setf conc-name (string conc-name))
42    (setf field-name (string field-name))
43    (intern (concatenate 'string conc-name field-name)))))
44
45(defun make-struct-make-fn (structure-name)
46  "Make the make- function for a structure"
47  (assert (typep structure-name '(or string symbol character)))
48  (setf structure-name (string structure-name))
49  (intern (concatenate 'string
50            (string '#:make-) structure-name)))
51
52(defun create-instance-of-type (type)
53  "Return an instance of a type.  Signal an error if
54  it can't figure out a value for the type."
55  (cond
56   ((eqt type t)  ;; anything
57    'a)
58   ((eqt type 'symbol)
59    'b)
60   ((eqt type 'null) nil)
61   ((eqt type 'boolean) t)
62   ((eqt type 'keyword) :foo)
63   ((eqt type nil) (error "Cannot obtain element of type ~S~%" type))
64   ((eqt type 'cons) (cons 'a 'b))
65   ((eqt type 'list) (list 1 2 3))
66   ((eqt type 'fixnum) 17)
67   ((eqt type 'bignum)
68    (let ((x 1))
69      (loop until (typep x 'bignum)
70          do (setq x (* 2 x)))
71      x))
72   ((and (symbolp type)
73         (typep type 'structure-class))
74    (let ((make-fn
75           (intern (concatenate 'string (string '#:make-) (symbol-name type))
76                   (symbol-package type))))
77      (eval (list make-fn))))
78   ((eqt type 'character) #\w)
79   ((eqt type 'base-char) #\z)
80   ((member type '(integer unsigned-byte signed-byte)) 35)
81   ((eqt type 'bit) 1)
82   ((and (consp type)
83         (consp (cdr type))
84         (consp (cddr type))
85         (null (cdddr type))
86         (eqt (car type) 'integer)
87         (integerp (second type)))
88    (second type))
89   ((member type '(float single-float long-float double-float short-float))
90    0.0)
91   ((and (consp type)
92         (eqt (car type) 'member)
93         (consp (cdr type)))
94    (second type))
95   ((and (consp type)
96         (eqt (car type) 'or)
97         (consp (second type)))
98    (create-instance-of-type (second type)))
99   (t (error "Cannot generate element for type ~S~%" type))))
100
101(defun find-option (option-list option &optional default)
102  (loop for opt in option-list
103        when (or (eq opt option)
104                 (and (consp opt)
105                      (eq (car opt) option)))
106        return opt
107        finally (return default)))
108
109(defvar *defstruct-with-tests-names* nil
110  "Names of structure types defined with DEFSRUCT-WITH-TESTS.")
111
112#|
113(defvar *subtypep-works-with-classes* t
114  "Becomes NIL if SUBTYPEP doesn't work with classes.  We test this first to avoid
115   repeated test failures that cause GCL to bomb.")
116
117(deftest subtypep-works-with-classes
118  (let ((c1 (find-class 'vector)))
119    ;; (setq *subtypep-works-with-classes* nil)
120    (subtypep c1 'vector)
121    (subtypep 'vector c1)
122    ;; (setq *subtypep-works-with-classes* t))
123  t)
124
125(defvar *typep-works-with-classes* t
126  "Becomes NIL if TYPEP doesn't work with classes.  We test this first to avoid
127   repeated test failures that cause GCL to bomb.")
128
129(deftest typep-works-with-classes
130  (let ((c1 (find-class 'vector)))
131    ;; (setq *typep-works-with-classes* nil)
132    (typep #(0 0) c1)
133    ;; (setq *typep-works-with-classes* t))
134  t)
135|#
136
137;;
138;; There are a number of standardized tests for
139;; structures.  The following macro generates the
140;; structure definition and the tests.
141;;
142
143(defmacro defstruct-with-tests
144    (name-and-options &body slot-descriptions-and-documentation)
145"Construct standardized tests for a defstruct, and also
146do the defstruct."
147  (defstruct-with-tests-fun name-and-options
148    slot-descriptions-and-documentation))
149
150(defun defstruct-with-tests-fun (name-and-options
151                                 slot-descriptions-and-documentation)
152  ;; Function called from macro defstruct-with-tests
153  (let* (
154         ;; Either NIL or the documentation string for the structure
155         (doc-string
156          (when (and (consp slot-descriptions-and-documentation)
157                     (stringp (car slot-descriptions-and-documentation)))
158            (car slot-descriptions-and-documentation)))
159
160         ;; The list of slot descriptions that follows either the
161         ;; name and options or the doc string
162         (slot-descriptions
163          (if doc-string (cdr slot-descriptions-and-documentation)
164            slot-descriptions-and-documentation))
165
166         ;; The name of the structure (should be a symbol)
167         (name (if (consp name-and-options)
168                   (car name-and-options)
169                 name-and-options))
170
171         ;; The options list, or NIL if there were no options
172         (options (if (consp name-and-options)
173                      (cdr name-and-options)
174                    nil))
175
176         ;; List of symbols that are the names of the slots
177         (slot-names
178          (loop
179           for x in slot-descriptions collect
180           (if (consp x) (car x) x)))
181
182         ;; List of slot types, if any
183         (slot-types
184          (loop
185           for x in slot-descriptions collect
186           (if (consp x)
187               (getf (cddr x) :type :none)
188             :none)))
189
190         ;; read-only flags for slots
191         (slot-read-only
192          (loop
193           for x in slot-descriptions collect
194           (and (consp x)
195                (getf (cddr x) :read-only))))
196
197         ;; Symbol obtained by prepending MAKE- to the name symbol
198         (make-fn (make-struct-make-fn name))
199
200         ;; The type option, if specified
201         (type-option (find-option options :type))
202         (struct-type (second type-option))
203
204         (named-option (find-option options :named))
205         (include-option (find-option options :include))
206
207         ;; The :predicate option entry from OPTIONS, or NIL if none
208         (predicate-option (find-option options :predicate))
209
210         ;; The name of the -P function, either the default or the
211         ;; one specified in the :predicate option
212         (p-fn-default (make-struct-p-fn name))
213         (p-fn (cond
214                ((and type-option (not named-option)) nil)
215                ((or (eq predicate-option :predicate)
216                     (null (cdr predicate-option)))
217                 p-fn-default)
218                ((cadr predicate-option) (cadr predicate-option))
219                (t nil)))
220
221         ;; The :copier option, or NIL if no such option specified
222         (copier-option (find-option options :copier))
223         ;; The name of the copier function, either the default or
224         ;; one speciefied in the :copier option
225         (copy-fn-default (make-struct-copy-fn name))
226         (copy-fn (cond
227                   ((or (eq copier-option :copier)
228                        (null (cdr copier-option)))
229                    copy-fn-default)
230                   ((cadr copier-option) (cadr copier-option))
231                   (t nil)))
232
233         ;; The :conc-name option, or NIL if none specified
234         (conc-option (find-option options :conc-name))
235         ;; String to be prepended to slot names to get the
236         ;; slot accessor function
237         (conc-prefix-default (concatenate 'string (string name) "-"))
238         (conc-prefix (cond
239                       ((null conc-option)
240                        conc-prefix-default)
241                       ((or (eq conc-option :conc-name)
242                            (null (cadr conc-option)))
243                        nil)
244                       (t (string (cadr conc-option)))))
245
246         (initial-offset-option (find-option options :initial-offset))
247         (initial-offset (second initial-offset-option))
248         
249         ;; Accessor names
250         (field-fns
251          (loop for slot-name in slot-names
252                collect (make-struct-field-fn conc-prefix slot-name)))
253
254         ;; a list of initial values
255         (initial-value-alist
256          (loop
257           for slot-desc in slot-descriptions
258           for slot-name in slot-names
259           for type      in slot-types
260           for i from 1
261           collect (if (not (eq type :none))
262                       (cons slot-name (create-instance-of-type type))
263                     (cons slot-name (defstruct-maketemp name "SLOTTEMP" i)))))
264         )
265    (declare (ignorable initial-offset))
266    ;; Build the tests in an eval-when form
267    `(eval-when (:load-toplevel :compile-toplevel :execute)
268
269       (report-and-ignore-errors
270        (eval '(defstruct ,name-and-options
271                 ,@slot-descriptions-and-documentation))
272        ,(unless (or type-option include-option)
273           `(pushnew ',name *defstruct-with-tests-names*))
274        nil)
275
276       ;; Test that structure is of the correct type
277       (deftest ,(make-struct-test-name name 1)
278         (and (fboundp (quote ,make-fn))
279              (functionp (function ,make-fn))
280              (symbol-function (quote ,make-fn))
281              (typep (,make-fn) (quote ,(if type-option struct-type
282                                          name)))
283              t)
284         t)
285
286       ;; Test that the predicate exists
287       ,@(when p-fn
288           `((deftest ,(make-struct-test-name name 2)
289               (let ((s (,make-fn)))
290                 (and (fboundp (quote ,p-fn))
291                      (functionp (function ,p-fn))
292                      (symbol-function (quote ,p-fn))
293                      (notnot (funcall #',p-fn s))
294                      (notnot-mv (,p-fn s))
295                      ))
296               t)
297             (deftest ,(make-struct-test-name name "ERROR.1")
298               (signals-error (,p-fn) program-error)
299               t)
300             (deftest ,(make-struct-test-name name "ERROR.2")
301               (signals-error (,p-fn (,make-fn) nil) program-error)
302               t)
303             ))
304
305       ;; Test that the elements of *universe* are not
306       ;; of this type
307       ,@(when p-fn
308           `((deftest ,(make-struct-test-name name 3)
309               (count-if (function ,p-fn) *universe*)
310               0)))
311       ,@(unless type-option
312           `((deftest ,(make-struct-test-name name 4)
313               (count-if (function (lambda (x) (typep x (quote ,name))))
314                         *universe*)
315               0)))
316
317       ;; Check that the fields can be read after being initialized
318       (deftest ,(make-struct-test-name name 5)
319         ,(let ((inits nil)
320                (tests nil)
321                (var (defstruct-maketemp name "TEMP-5")))
322            (loop
323             for (slot-name . initval) in initial-value-alist
324             for field-fn in field-fns
325             do
326             (setf inits
327                   (list* (intern (string slot-name) "KEYWORD")
328                          (list 'quote initval)
329                          inits))
330             (push `(and
331                     (eqlt (quote ,initval)
332                           (,field-fn ,var))
333                     (eqlt (quote ,initval)
334                           (funcall #',field-fn ,var)))
335                   tests))
336            `(let ((,var (,make-fn . ,inits)))
337               (and ,@tests t)))
338         t)
339
340       (deftest ,(make-struct-test-name name "ERROR.3")
341         (remove nil
342                 (list
343                  ,@(loop
344                     for (slot-name . initval) in initial-value-alist
345                     for field-fn in field-fns
346                     collect
347                     `(multiple-value-bind
348                          (x val)
349                          (signals-error (,field-fn) program-error)
350                        (unless x
351                          (list ',slot-name ',field-fn val))))))
352         nil)
353
354       (deftest ,(make-struct-test-name name "ERROR.4")
355         (remove nil
356                 (list
357                  ,@(loop
358                     for (slot-name . initval) in initial-value-alist
359                     for field-fn in field-fns
360                     collect
361                     `(multiple-value-bind
362                          (x val)
363                          (signals-error (,field-fn (,make-fn) nil)
364                                         program-error)
365                        (unless x
366                          (list ',slot-name ',field-fn val))))))
367         nil)
368
369       ;; Check that two invocations return different structures
370       (deftest ,(make-struct-test-name name 6)
371         (eqt (,make-fn) (,make-fn))
372         nil)
373
374       ;; Check that we can setf the fields
375       (deftest ,(make-struct-test-name name 7)
376         ,(let* ((var (defstruct-maketemp name "TEMP-7-1"))
377                 (var2 (defstruct-maketemp name "TEMP-7-2"))
378                 (tests
379                  (loop
380                   for (slot-name . initval) in initial-value-alist
381                   for read-only-p in slot-read-only
382                   for slot-desc in slot-descriptions
383                   for field-fn in field-fns
384                   unless read-only-p
385                   collect
386                   `(let ((,var2 (quote ,initval)))
387                      (setf (,field-fn ,var) ,var2)
388                      (eqlt (,field-fn ,var) ,var2)))))
389            `(let ((,var (,make-fn)))
390               (and ,@tests t)))
391         t)
392
393       ;; Check that the copy function exists
394       ,@(when copy-fn
395           `((deftest ,(make-struct-test-name name 8)
396               (and (fboundp (quote ,copy-fn))
397                    (functionp (function ,copy-fn))
398                    (symbol-function (quote ,copy-fn))
399                    t)
400               t)
401             (deftest ,(make-struct-test-name name "ERROR.5")
402               (signals-error (,copy-fn) program-error)
403               t)
404             (deftest ,(make-struct-test-name name "ERROR.6")
405               (signals-error (,copy-fn (,make-fn) nil) program-error)
406               t)
407             ))     
408
409       ;; Check that the copy function properly copies fields
410       ,@(when copy-fn
411           `((deftest ,(make-struct-test-name name 9)
412               ,(let* ((var 'XTEMP-9)
413                       (var2 'YTEMP-9)
414                       (var3 'ZTEMP-9))       
415                  `(let ((,var (,make-fn
416                                ,@(loop
417                                   for (slot-name . initval)
418                                   in initial-value-alist
419                                   nconc (list (intern (string slot-name)
420                                                       "KEYWORD")
421                                               `(quote ,initval))))))
422                     (let ((,var2 (,copy-fn ,var))
423                           (,var3 (funcall #',copy-fn ,var)))
424                       (and
425                        (not (eqlt ,var ,var2))
426                        (not (eqlt ,var ,var3))
427                        (not (eqlt ,var2 ,var3))
428                        ,@(loop
429                           for (slot-name . nil) in initial-value-alist
430                           for fn in field-fns
431                           collect
432                           `(and (eqlt (,fn ,var) (,fn ,var2))
433                                 (eqlt (,fn ,var) (,fn ,var3))))
434                        t))))
435               t)))
436
437       ;; When the predicate is not the default, check
438       ;; that the default is not defined.  Tests should
439       ;; be designed so that this function name doesn't
440       ;; collide with anything else.
441       ,@(unless (eq p-fn p-fn-default)
442           `((deftest ,(make-struct-test-name name 10)
443               (fboundp (quote ,p-fn-default))
444               nil)))
445
446       ;; When the copy function name is not the default, check
447       ;; that the default function is not defined.  Tests should
448       ;; be designed so that this name is not accidently defined
449       ;; for something else.
450       ,@(unless (eq copy-fn copy-fn-default)
451           `((deftest ,(make-struct-test-name name 11)
452               (fboundp (quote ,copy-fn-default))
453               nil)))
454
455       ;; When there are read-only slots, test that the SETF
456       ;; form for them is not FBOUNDP
457       ,@(when (loop for x in slot-read-only thereis x)
458           `((deftest ,(make-struct-test-name name 12)
459               (and
460                ,@(loop for slot-name in slot-names
461                        for read-only in slot-read-only
462                        for field-fn in field-fns
463                        when read-only
464                        collect `(not-mv (fboundp '(setf ,field-fn))))
465                t)
466               t)))
467
468       ;; When the structure is a true structure type, check that
469       ;; the various class relationships hold
470       ,@(unless type-option
471           `(
472             (deftest ,(make-struct-test-name name 13)
473               (notnot-mv (typep (,make-fn) (find-class (quote ,name))))
474               t)
475             (deftest ,(make-struct-test-name name 14)
476               (let ((class (find-class (quote ,name))))
477                 (notnot-mv (typep class 'structure-class)))
478               t)
479             (deftest ,(make-struct-test-name name 15)
480               (notnot-mv (typep (,make-fn) 'structure-object))
481               t)
482             (deftest ,(make-struct-test-name name 16)
483               (loop for type in *disjoint-types-list*
484                     unless (and
485                             (equalt (multiple-value-list
486                                      (subtypep* type (quote ,name)))
487                                     '(nil t))
488                             (equalt (multiple-value-list
489                                      (subtypep* (quote ,name) type))
490                                     '(nil t)))                             
491                     collect type)
492               nil)
493             (deftest ,(make-struct-test-name name 17)
494               (let ((class (find-class (quote ,name))))
495                 (loop for type in *disjoint-types-list*
496                       unless (and
497                               (equalt (multiple-value-list
498                                        (subtypep* type class))
499                                       '(nil t))
500                               (equalt (multiple-value-list
501                                        (subtypep* class type))
502                                       '(nil t)))
503                       collect type))
504               nil)
505             (deftest ,(make-struct-test-name name "15A")
506               (let ((class (find-class (quote ,name))))
507                 (notnot-mv (subtypep class 'structure-object)))
508               t t)
509             (deftest ,(make-struct-test-name name "15B")
510               (notnot-mv (subtypep (quote ,name) 'structure-object))
511               t t)
512
513             ))
514
515       ;;; Documentation tests
516
517       ,(when doc-string
518          `(deftest ,(make-struct-test-name name 18)
519             (let ((doc (documentation ',name 'structure)))
520               (or (null doc) (equalt doc ',doc-string)))
521             t))
522
523       ,(when (and doc-string (not type-option))
524          `(deftest ,(make-struct-test-name name 19)
525             (let ((doc (documentation ',name 'type)))
526               (or (null doc) (equalt doc ',doc-string)))
527             t))
528
529       ;; Test that COPY-STRUCTURE works, if this is a structure
530       ;; type
531       ,@(unless type-option
532           `((deftest ,(make-struct-test-name name 20)
533               ,(let* ((var 'XTEMP-20)
534                       (var2 'YTEMP-20))
535                  `(let ((,var (,make-fn
536                                ,@(loop
537                                   for (slot-name . initval)
538                                   in initial-value-alist
539                                   nconc (list (intern (string slot-name)
540                                                       "KEYWORD")
541                                               `(quote ,initval))))))
542                     (let ((,var2 (copy-structure ,var)))
543                       (and
544                        (not (eqlt ,var ,var2))
545                        ,@(loop
546                           for (slot-name . nil) in initial-value-alist
547                           for fn in field-fns
548                           collect
549                           `(eqlt (,fn ,var) (,fn ,var2)))
550                        t))))
551               t)))
552       nil
553       )))
554
555(defun defstruct-maketemp (stem suffix1 &optional suffix2)
556  "Make a temporary variable for DEFSTRUCT-WITH-TESTS."
557  (intern (if suffix2 (format nil "~A-~A-~A" stem suffix1 suffix2)
558            (format nil "~A-~A" stem suffix1))))
Note: See TracBrowser for help on using the repository browser.