source: trunk/source/tests/ansi-tests/structures-02.lsp @ 8991

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

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

File size: 13.2 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun May  3 22:46:54 1998
4;;;; Contains: Test code for structures, part 02
5
6(in-package :cl-test)
7(declaim (optimize (safety 3)))
8
9;; Test initializers for fields
10
11(defvar *s-2-f6-counter* 0)
12
13(defstruct s-2
14  (f1 0)
15  (f2 'a)
16  (f3 1.21)
17  (f4 #\d)
18  (f5 (list 'a 'b))
19  (f6 (incf *s-2-f6-counter*)))
20
21;; Standard structure tests
22
23
24;; Fields have appropriate values
25(deftest structure-2-1
26  (let ((*s-2-f6-counter* 0))
27    (let ((s (make-s-2)))
28      (and
29       (eqlt (s-2-f1 s) 0)
30       (eqt  (s-2-f2 s) 'a)
31       (= (s-2-f3 s) 1.21)
32       (eqlt (s-2-f4 s) #\d)
33       (equalt (s-2-f5 s) '(a b))
34       (eqlt (s-2-f6 s) *s-2-f6-counter*)
35       (eqlt *s-2-f6-counter* 1))))
36  t)
37
38;; Two successive invocations of make-s-2 return different objects
39(deftest structure-2-2
40  (let ((*s-2-f6-counter* 0))
41    (eqt (s-2-f5 (make-s-2))
42         (s-2-f5 (make-s-2))))
43  nil)
44
45;; Creation with various fields does the right thing
46(deftest structure-2-3
47  (let* ((*s-2-f6-counter* 0)
48         (s (make-s-2 :f1 17)))
49    (and
50     (eqlt (s-2-f1 s) 17)
51     (eqt  (s-2-f2 s) 'a)
52     (= (s-2-f3 s) 1.21)
53     (eqlt (s-2-f4 s) #\d)
54     (equalt (s-2-f5 s) '(a b))
55     (eqlt (s-2-f6 s) *s-2-f6-counter*)
56     (eqlt *s-2-f6-counter* 1)))
57  t)
58
59(deftest structure-2-4
60  (let* ((*s-2-f6-counter* 0)
61         (s (make-s-2 :f2 'z)))
62    (and
63     (eqlt (s-2-f1 s) 0)
64     (eqt  (s-2-f2 s) 'z)
65     (= (s-2-f3 s) 1.21)
66     (eqlt (s-2-f4 s) #\d)
67     (equalt (s-2-f5 s) '(a b))
68     (eqlt (s-2-f6 s) *s-2-f6-counter*)
69     (eqlt *s-2-f6-counter* 1)))
70  t)
71
72(deftest structure-2-5
73  (let* ((*s-2-f6-counter* 0)
74         (s (make-s-2 :f3 1.0)))
75    (and
76     (eqlt (s-2-f1 s) 0)
77     (eqt  (s-2-f2 s) 'a)
78     (= (s-2-f3 s) 1.0)
79     (eqlt (s-2-f4 s) #\d)
80     (equalt (s-2-f5 s) '(a b))
81     (eqlt (s-2-f6 s) *s-2-f6-counter*)
82     (eqlt *s-2-f6-counter* 1)))
83  t)
84
85(deftest structure-2-6
86  (let* ((*s-2-f6-counter* 0)
87         (s (make-s-2 :f4 #\z)))
88    (and
89     (eqlt (s-2-f1 s) 0)
90     (eqt  (s-2-f2 s) 'a)
91     (= (s-2-f3 s) 1.21)
92     (eqlt (s-2-f4 s) #\z)
93     (equalt (s-2-f5 s) '(a b))
94     (eqlt (s-2-f6 s) *s-2-f6-counter*)
95     (eqlt *s-2-f6-counter* 1)))
96  t)
97
98(deftest structure-2-7
99  (let* ((*s-2-f6-counter* 0)
100         (s (make-s-2 :f5 '(c d e))))
101    (and
102     (eqlt (s-2-f1 s) 0)
103     (eqt  (s-2-f2 s) 'a)
104     (= (s-2-f3 s) 1.21)
105     (eqlt (s-2-f4 s) #\d)
106     (equalt (s-2-f5 s) '(c d e))
107     (eqlt (s-2-f6 s) *s-2-f6-counter*)
108     (eqlt *s-2-f6-counter* 1)))
109  t)
110
111(deftest structure-2-8
112  (let* ((*s-2-f6-counter* 0)
113         (s (make-s-2 :f6 10)))
114    (and
115     (eqlt (s-2-f1 s) 0)
116     (eqt  (s-2-f2 s) 'a)
117     (= (s-2-f3 s) 1.21)
118     (eqlt (s-2-f4 s) #\d)
119     (equalt (s-2-f5 s) '(a b))
120     (eqlt (s-2-f6 s) 10)
121     (eqlt *s-2-f6-counter* 0)))
122  t)
123
124;;; Tests using the defstruct-with-tests infrastructure
125
126(defstruct-with-tests struct-test-03 a b c d)
127
128(defstruct-with-tests (struct-test-04) a b c)
129
130(defstruct-with-tests (struct-test-05 :constructor) a05 b05 c05)
131(defstruct-with-tests (struct-test-06 (:constructor)) a06 b06 c06)
132
133(defstruct-with-tests (struct-test-07 :conc-name) a07 b07)
134(defstruct-with-tests (struct-test-08 (:conc-name)) a08 b08)
135(defstruct-with-tests (struct-test-09 (:conc-name nil)) a09 b09)
136(defstruct-with-tests (struct-test-10 (:conc-name "")) a10 b10)
137(defstruct-with-tests (struct-test-11 (:conc-name "BLAH-")) a11 b11)
138(defstruct-with-tests (struct-test-12 (:conc-name BLAH-)) a12 b12)
139(defstruct-with-tests (struct-test-13 (:conc-name #\X)) foo-a13 foo-b13)
140
141(defstruct-with-tests (struct-test-14 (:predicate)) a14 b14)
142(defstruct-with-tests (struct-test-15 (:predicate nil)) a15 b15)
143(defstruct-with-tests (struct-test-16 :predicate) a16 b16)
144(defstruct-with-tests (struct-test-17
145                       (:predicate struct-test-17-alternate-pred))
146  a17 b17)
147
148(defstruct-with-tests (struct-test-18 :copier) a18 b18)
149(defstruct-with-tests (struct-test-19 (:copier)) a19 b19)
150(defstruct-with-tests (struct-test-20 (:copier nil)) a20 b20)
151(defstruct-with-tests (struct-test-21 (:copier struct-test-21-alt-copier))
152  a21 b21)
153
154(defstruct-with-tests struct-test-22 (a22) (b22))
155(defstruct-with-tests struct-test-23 (a23 1) (b23 2))
156(defstruct-with-tests struct-test-24
157  (a24 1 :type fixnum)
158  (b24 2 :type integer))
159
160(defstruct-with-tests struct-test-25)
161(defstruct-with-tests struct-test-26
162  (a26 nil :read-only nil)
163  (b26 'a  :read-only nil))
164
165(defstruct-with-tests struct-test-27
166  (a27 1    :read-only t)
167  (b27 1.4  :read-only a))
168
169(defstruct-with-tests struct-test-28
170  (a28 1    :type integer :read-only t)
171  (b28 'xx  :read-only a :type symbol))
172
173(defstruct-with-tests struct-test-29
174  a29
175  (b29 'xx  :read-only 1)
176  c29)
177
178(defstruct-with-tests struct-test-30 #:a30 #:b30)
179(defstruct-with-tests #:struct-test-31 a31 b31)
180
181(defpackage struct-test-package (:use))
182
183(defstruct-with-tests struct-test-32
184  struct-test-package::a32 struct-test-package::b32)
185
186;;; If the :conc-name option is given no argument or
187;;; a nil argument, the accessor names are the same as
188;;; slot names.  Note that this is different from prepending
189;;; an empty string, since that may get you a name in
190;;; a different package.
191
192(defstruct-with-tests (struct-test-33 (:conc-name))
193  struct-test-package::a33 struct-test-package::b33)
194(defstruct-with-tests (struct-test-34 :conc-name)
195  struct-test-package::a34 struct-test-package::b34)
196(defstruct-with-tests (struct-test-35 (:conc-name nil))
197  struct-test-package::a35 struct-test-package::b35)
198
199(defstruct-with-tests (struct-test-36 (:conc-name ""))
200  struct-test-package::st36-a36 struct-test-package::st26-b36)
201
202;;; List and vector structures
203
204(defstruct-with-tests (struct-test-37 (:type list)) a37 b37 c37)
205
206(deftest structure-37-1
207  (make-struct-test-37 :a37 1 :b37 2 :c37 4)
208  (1 2 4))
209
210(defstruct-with-tests (struct-test-38 (:type list) :named) a38 b38 c38)
211
212(deftest structure-38-1
213  (make-struct-test-38 :a38 11 :b38 12 :c38 4)
214  (struct-test-38 11 12 4))
215
216(defstruct-with-tests (struct-test-39 (:predicate nil)
217                                      (:type list) :named)
218  a39 b39 c39)
219
220(deftest structure-39-1
221  (make-struct-test-39 :a39 11 :b39 12 :c39 4)
222  (struct-test-39 11 12 4))
223
224(defstruct-with-tests (struct-test-40 (:type vector)) a40 b40)
225(defstruct-with-tests (struct-test-41 (:type vector) :named) a41 b41)
226(defstruct-with-tests (struct-test-42 (:type (vector t))) a42 b42)
227(defstruct-with-tests (struct-test-43 (:type (vector t)) :named) a43 b43)
228
229(defstruct-with-tests (struct-test-44 (:type list))
230  (a44 0 :type integer)
231  (b44 'a :type symbol))
232
233;;; Confirm that the defined structure types are all disjoint
234(deftest structs-are-disjoint
235  (loop for s1 in *defstruct-with-tests-names*
236        sum (loop for s2 in *defstruct-with-tests-names*
237                  unless (eq s1 s2)
238                  count (not (equalt (multiple-value-list
239                                      (subtypep* s1 s2))
240                                     '(nil t)))))
241  0)
242
243(defstruct-with-tests (struct-test-45 (:type list) (:initial-offset 2))
244  a45 b45)
245
246(deftest structure-45-1
247  (cddr (make-struct-test-45 :a45 1 :b45 2))
248  (1 2))
249
250(defstruct-with-tests (struct-test-46 (:type list)
251                                      (:include struct-test-45))
252  c46 d46)
253
254(deftest structure-46-1
255  (cddr (make-struct-test-46 :a45 1 :b45 2 :c46 3 :d46 4))
256  (1 2 3 4))
257
258(defstruct-with-tests (struct-test-47 (:type list)
259                                      (:initial-offset 3)
260                                      (:include struct-test-45))
261  c47 d47)
262
263(deftest structure-47-1
264  (let ((s (make-struct-test-47 :a45 1 :b45 2 :c47 3 :d47 4)))
265    (values (third s) (fourth s) (eighth s) (ninth s)))
266  1 2 3 4)
267
268(defstruct-with-tests (struct-test-48 (:type list)
269                                      (:initial-offset 0)
270                                      (:include struct-test-45))
271  c48 d48)
272
273(deftest structure-48-1
274  (cddr (make-struct-test-48 :a45 1 :b45 2 :c48 3 :d48 4))
275  (1 2 3 4))
276
277(defstruct-with-tests (struct-test-49 (:type (vector bit)))
278  (a49 0 :type bit)
279  (b49 0 :type bit))
280
281(defstruct-with-tests (struct-test-50 (:type (vector character)))
282  (a50 #\g :type character)
283  (b50 #\k :type character))
284
285(defstruct-with-tests (struct-test-51 (:type (vector (integer 0 255))))
286  (a51 17 :type (integer 0 255))
287  (b51 25 :type (integer 0 255)))
288
289(defstruct-with-tests (struct-test-52 (:type vector)
290                                      (:initial-offset 0))
291  a52 b52)
292
293(defstruct-with-tests (struct-test-53 (:type vector)
294                                      (:initial-offset 5))
295  "This is struct-test-53"
296  a53 b53)
297
298(deftest structure-53-1
299  (let ((s (make-struct-test-53 :a53 10 :b53 'a)))
300    (values (my-aref s 5) (my-aref s 6)))
301  10 a)
302
303(defstruct-with-tests (struct-test-54 (:type vector)
304                                      (:initial-offset 2)
305                                      (:include struct-test-53))
306  "This is struct-test-54"
307  a54 b54)
308
309(deftest structure-54-1
310  (let ((s (make-struct-test-54 :a53 8 :b53 'g :a54 10 :b54 'a)))
311    (values (my-aref s 5) (my-aref s 6) (my-aref s 9) (my-aref s 10)))
312  8 g 10 a)
313
314(defstruct-with-tests (struct-test-55 (:type list)
315                                      (:initial-offset 2)
316                                      :named)
317  a55 b55 c55)
318
319(deftest structure-55-1
320  (let ((s (make-struct-test-55 :a55 'p :c55 'q)))
321    (values (third s) (fourth s) (sixth s)))
322  struct-test-55 p q)
323
324(defstruct-with-tests (struct-test-56 (:type list)
325                                      (:initial-offset 3)
326                                      (:include struct-test-55)
327                                      :named)
328  d56 e56)
329
330(deftest structure-56-1
331  (let ((s (make-struct-test-56 :a55 3 :b55 7 :d56 'x :e56 'y)))
332    (mapcar #'(lambda (i) (nth i s)) '(2 3 4 9 10 11)))
333  (struct-test-55 3 7 struct-test-56 x y))
334
335(defstruct-with-tests (struct-test-57 (:include struct-test-22))
336  c57 d57)
337
338(defstruct-with-tests struct-test-58
339  "This is struct-test-58"  a-58 b-58)
340
341(defstruct-with-tests (struct-test-59 (:include struct-test-58))
342  "This is struct-test-59"  a-59 b-59)
343
344;;; When a field name of a structure is also a special variable,
345;;; the constructor must not bind that name.
346
347(defvar *st-60* 100)
348
349(defstruct-with-tests struct-test-60
350  (a60 *st-60* :type integer)
351  (*st-60* 0 :type integer)
352  (b60 *st-60* :type integer))
353
354(deftest structure-60-1
355  (let ((*st-60* 10))
356    (let ((s (make-struct-test-60 :*st-60* 200)))
357      (values (struct-test-60-a60 s)
358              (struct-test-60-*st-60* s)
359              (struct-test-60-b60 s))))
360  10 200 10)
361
362
363;;; When default initializers of the wrong type are given, they do not
364;;; cause an error unless actually invoked
365
366(defstruct struct-test-61
367  (a nil :type integer)
368  (b 0 :type symbol))
369
370(deftest structure-61-1
371  (let ((s (make-struct-test-61 :a 10 :b 'c)))
372    (values (struct-test-61-a s)
373            (struct-test-61-b s)))
374  10 c)
375
376;;; Initializer forms are evaluated only when needed, and are
377;;; evaluated in the lexical environment in which they were defined
378
379(eval-when (:load-toplevel :execute)
380  (let ((x nil))
381    (flet ((%f () x)
382          (%g (y) (setf x y)))
383      (defstruct struct-test-62
384        (a (progn (setf x 'a) nil))
385        (f #'%f)
386        (g #'%g)))))
387
388(deftest structure-62-1
389  (let* ((s (make-struct-test-62 :a 1))
390         (f (struct-test-62-f s)))
391    (assert (typep f 'function))
392    (values
393     (struct-test-62-a s)
394     (funcall (the function f))))
395  1 nil)
396
397(deftest structure-62-2
398  (let* ((s (make-struct-test-62))
399         (f (struct-test-62-f s))
400         (g (struct-test-62-g s)))
401    (assert (typep f 'function))
402    (assert (typep g 'function))
403    (locally
404     (declare (type function f g))
405     (values
406      (struct-test-62-a s)
407      (funcall f)
408      (funcall g nil)
409      (funcall f))))
410  nil a nil nil)
411
412;;; Keywords are allowed in defstruct
413(defstruct-with-tests :struct-test-63 a63 b63 c63)
414(defstruct-with-tests struct-test-64 :a63 :b63 :c63)
415
416(defstruct-with-tests struct-test-65
417    array-dimension-limit
418    array-rank-limit
419    array-total-size-limit
420    boole-1
421    boole-2
422    boole-and
423    boole-andc1
424    boole-andc2
425    boole-c1
426    boole-c2
427    boole-clr
428    boole-eqv
429    boole-ior
430    boole-nand
431    boole-nor
432    boole-orc1
433    boole-orc2
434    boole-set
435    boole-xor
436    call-arguments-limit
437    char-code-limit
438    double-float-epsilon
439    double-float-negative-epsilon
440    internal-time-units-per-second
441    lambda-list-keywords
442    lambda-parameters-limit
443    least-negative-double-float
444    least-negative-long-float
445    least-negative-normalized-double-float
446    least-negative-normalized-long-float
447    least-negative-normalized-short-float
448    least-negative-normalized-single-float
449    least-negative-short-float
450    least-negative-single-float
451    least-positive-double-float
452    least-positive-long-float
453    least-positive-normalized-double-float
454    least-positive-normalized-long-float
455    least-positive-normalized-short-float
456    least-positive-normalized-single-float
457    least-positive-short-float
458    least-positive-single-float
459    long-float-epsilon
460    long-float-negative-epsilon
461    most-negative-double-float
462    most-negative-fixnum
463    most-negative-long-float
464    most-negative-short-float
465    most-negative-single-float
466    most-positive-double-float
467    most-positive-fixnum
468    most-positive-long-float
469    most-positive-short-float
470    most-positive-single-float
471    multiple-values-limit
472    pi
473    short-float-epsilon
474    short-float-negative-epsilon
475    single-float-epsilon
476    single-float-negative-epsilon
477    t)
478
479(defstruct-with-tests struct-test-66 nil)
480
481(defstruct-with-tests struct-test-67
482  (a 0 :type (integer 0 (#.(ash 1 32))))
483  (b nil))
484
485(defstruct-with-tests (struct-test-68 (:include struct-test-67))
486  c d) 
487
488;;; Error tests
489
490(deftest copy-structure.error.1
491  (signals-error (copy-structure) program-error)
492  t)
493
494(deftest copy-structure.error.2
495  (signals-error (copy-structure (make-s-2) nil) program-error)
496  t)
497
Note: See TracBrowser for help on using the repository browser.