source: trunk/source/tests/ansi-tests/slot-exists-p.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: 4.9 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat May 10 09:39:01 2003
4;;;; Contains: Tests of SLOT-EXISTS-P
5
6(in-package :cl-test)
7
8;;; This function is also tested incidentally in many other files
9
10(defclass slot-exists-p-class-01 ()
11  (a (b :allocation :class) (c :allocation :instance)))
12
13(deftest slot-exists-p.1
14  (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))))
15    (notnot-mv (slot-exists-p obj 'a)))
16  t)
17     
18(deftest slot-exists-p.2
19  (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))))
20    (notnot-mv (slot-exists-p obj 'b)))
21  t)
22     
23(deftest slot-exists-p.3
24  (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))))
25    (notnot-mv (slot-exists-p obj 'c)))
26  t)
27
28(deftest slot-exists-p.4
29  (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))))
30    (slot-exists-p obj 'd))
31  nil)
32
33(deftest slot-exists-p.5
34  (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))))
35    (slot-exists-p obj (gensym)))
36  nil)
37
38(deftest slot-exists-p.6
39  (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))))
40    (slot-exists-p obj nil))
41  nil)
42
43(deftest slot-exists-p.7
44  (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))))
45    (slot-exists-p obj t))
46  nil)
47
48;;; SLOT-EXISTS-P may be called on any object, not just on standard objects
49
50(deftest slot-exists-p.8
51  (let ((slot-name (gensym)))
52    (check-predicate #'(lambda (x) (not (slot-exists-p x slot-name)))))
53  nil)
54
55;;; With various types
56
57(defclass slot-exists-p-class-02 ()
58  ((a :type t) (b :type nil) (c :type symbol) (d :type cons)
59   (e :type float) (f :type single-float) (g :type short-float)
60   (h :type double-float) (i :type long-float) (j :type character)
61   (k :type base-char) (l :type rational) (m :type ratio) (n :type integer)
62   (o :type fixnum) (p :type complex) (q :type condition)))
63
64(deftest slot-exists-p.9
65  (let ((obj (allocate-instance (find-class 'slot-exists-p-class-02))))
66    (map-slot-exists-p* obj '(a b c d e f g h i j k l m n o p q)))
67  (t t t t t t t t t t t t t t t t t))
68
69;;; Inheritance
70
71(defclass slot-exists-p-class-03a ()
72  (a b))
73
74(defclass slot-exists-p-class-03b ()
75  (a c))
76
77(defclass slot-exists-p-class-03c (slot-exists-p-class-03a slot-exists-p-class-03b)
78  (d e))
79
80(deftest slot-exists-p.10
81  (let ((obj (allocate-instance (find-class 'slot-exists-p-class-03c))))
82    (map-slot-exists-p* obj '(a b c d e f g)))
83  (t t t t t nil nil))
84
85;;; SLOT-EXISTS-P is supposed to work on structure objects and condition objects
86
87(defstruct slot-exists-p-struct-01
88  a b c)
89
90(deftest slot-exists-p.11
91  (let ((obj (make-slot-exists-p-struct-01)))
92    (map-slot-exists-p* obj '(a b c z nil)))
93  (t t t nil nil))
94
95(deftest slot-exists-p.12
96  (let ((obj (make-slot-exists-p-struct-01 :a 1 :b 2 :c 3)))
97    (map-slot-exists-p* obj '(a b c z nil)))
98  (t t t nil nil))
99
100(defstruct (slot-exists-p-struct-02 (:include slot-exists-p-struct-01))
101  d e)
102   
103(deftest slot-exists-p.13
104  (let ((obj (make-slot-exists-p-struct-02)))
105    (map-slot-exists-p* obj '(a b c d e f z nil)))
106  (t t t t t nil nil nil))
107
108(deftest slot-exists-p.14
109  (let ((obj (make-slot-exists-p-struct-02 :a 1 :b 3 :e 5)))
110    (map-slot-exists-p* obj '(a b c d e f z nil)))
111  (t t t t t nil nil nil))
112
113 
114;;; SLOT-EXISTS-P is supposed to work on condition objects, too
115;;; (after all, they are objects, and they have slots)
116
117(define-condition slot-exists-p-condition-01 ()
118  ((a) (b) (c)))
119
120(deftest slot-exists-p.15
121  (let ((obj (make-condition 'slot-exists-p-condition-01)))
122    (map-slot-exists-p* obj (list 'a 'b 'c (gensym))))
123  (t t t nil))
124
125(define-condition slot-exists-p-condition-02 (slot-exists-p-condition-01)
126  ((a) (d) (e)))
127
128(deftest slot-exists-p.16
129  (let ((obj (make-condition 'slot-exists-p-condition-02)))
130    (map-slot-exists-p* obj (list 'a 'b 'c 'd 'e (gensym))))
131  (t t t t t nil))
132
133;;; Order of evaluation tests
134
135(deftest slot-exists-p.order.1
136  (let ((i 0) x y)
137    (values
138     (slot-exists-p (progn (setf x (incf i)) 'a)
139                    (progn (setf y (incf i)) (gensym)))
140     i x y))
141  nil 2 1 2)
142
143(deftest slot-exists-p.order.2
144  (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))
145        (i 0) x y)
146    (values
147     (notnot (slot-exists-p (progn (setf x (incf i)) obj)
148                            (progn (setf y (incf i)) 'a)))
149     i x y))
150  t 2 1 2)
151
152(deftest slot-exists-p.order.3
153  (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))
154        (i 0) x y)
155    (values
156     (notnot (slot-exists-p (progn (setf x (incf i)) obj)
157                            (progn (setf y (incf i)) 'b)))
158     i x y))
159  t 2 1 2)
160
161;;; Errors tests
162
163(deftest slot-exists-p.error.1
164  (signals-error (slot-exists-p) program-error)
165  t)
166
167(deftest slot-exists-p.error.2
168  (signals-error (slot-exists-p 'a) program-error)
169  t)
170
171(deftest slot-exists-p.error.3
172  (signals-error (slot-exists-p (make-instance 'slot-exists-p-class-01))
173                 program-error)
174  t)
175
176(deftest slot-exists-p.error.4
177  (signals-error (slot-exists-p (make-instance 'slot-exists-p-class-01) 'a nil)
178                 program-error)
179  t)
180
181
Note: See TracBrowser for help on using the repository browser.