source: trunk/source/tests/ansi-tests/structures-01.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: 2.3 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat May  2 21:45:32 1998
4;;;; Contains: Test code for structures, part 01
5
6(in-package :cl-test)
7(declaim (optimize (safety 3)))
8
9;;; Tests for structures
10;;;
11;;; The CL Spec leaves undefined just what will happen when a structure is
12;;; redefined.  These tests don't redefine structures, but reloading a file
13;;; with structure definition will do so.  I assume that this leaves the
14;;; structure type unchanged.
15
16;; Test simple defstruct (fields, no options)
17
18(defstruct s-1
19  foo bar)
20
21;; Test that make-s-1 produces objects
22;; of the correct type
23(deftest structure-1-1
24  (notnot-mv (typep (make-s-1) 's-1))
25  t)
26
27;; Test that the -p predicate exists
28(deftest structure-1-2
29  (notnot-mv (s-1-p (make-s-1)))
30  t)
31
32;; Test that all the objects in the universe are
33;; not of this type
34(deftest structure-1-3
35  (count-if #'s-1-p *universe*)
36  0)
37
38(deftest structure-1-4
39  (count-if #'(lambda (x) (typep x 's-1)) *universe*)
40  0)
41
42;; Check that the fields can be read after being initialized
43(deftest structure-1-5
44  (s-1-foo (make-s-1 :foo 'a))
45  a)
46
47(deftest structure-1-6
48  (s-1-bar (make-s-1 :bar 'b))
49  b)
50
51(deftest structure-1-7
52  (let ((s (make-s-1 :foo 'c :bar 'd)))
53    (list (s-1-foo s) (s-1-bar s)))
54  (c d))
55
56;; Can setf the fields
57(deftest structure-1-8
58  (let ((s (make-s-1)))
59    (setf (s-1-foo s) 'e)
60    (setf (s-1-bar s) 'f)
61    (list (s-1-foo s) (s-1-bar s)))
62  (e f))
63
64(deftest structure-1-9
65  (let ((s (make-s-1 :foo 'a :bar 'b)))
66    (setf (s-1-foo s) 'e)
67    (setf (s-1-bar s) 'f)
68    (list (s-1-foo s) (s-1-bar s)))
69  (e f))
70
71;; copier function defined
72(deftest structure-1-10
73  (let ((s (make-s-1 :foo 'a :bar 'b)))
74    (let ((s2 (copy-s-1 s)))
75      (setf (s-1-foo s) nil)
76      (setf (s-1-bar s) nil)
77      (list (s-1-foo s2)
78            (s-1-bar s2))))
79  (a b))
80
81;; Make produces unique items
82(deftest structure-1-11
83  (eqt (make-s-1) (make-s-1))
84  nil)
85
86(deftest structure-1-12
87  (eqt (make-s-1 :foo 'a :bar 'b)
88       (make-s-1 :foo 'a :bar 'b))
89  nil)
90
91;; More type and class checks
92
93(deftest structure-1-13
94  (notnot-mv (typep (class-of (make-s-1)) 'structure-class))
95  t)
96
97(deftest structure-1-14
98  (notnot-mv (typep (make-s-1) 'structure-object))
99  t)
100
101(deftest structure-1-15
102  (subtypep* 's-1 'structure-object)
103  t t)
Note: See TracBrowser for help on using the repository browser.