1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303 | with AUnit.Assertions; use AUnit.Assertions;
with AUnit.Test_Cases; use AUnit.Test_Cases;
with Ada.Assertions;
with Ada.Containers;
with Minimal_Containers.Bounded_Vectors;
package body Vectors_Tests is
package Tests is
type T is new Test_Case with null record;
overriding function Name (C : T) return AUnit.Message_String;
overriding procedure Register_Tests (C : in out T);
-- procedure Set_Up (C : in out T);
-- procedure Tear_Down (C : in out t);
end Tests;
use AUnit;
package body Tests is
overriding function Name (C : T) return AUnit.Message_String
is (Format ("Vectors"));
use Ada.Containers; -- for Count_Type, Capacity_Error
type Index_Base is range 0 .. 6;
subtype Index_Type is Index_Base range 1 .. 5;
type Element_Type is (K, L, M, N, P);
Expected_Values : constant array (Index_Type) of Element_Type
:= (1 => K,
2 => L,
3 => M,
4 => N,
5 => P);
Index_For : constant array (Element_Type) of Index_Type
:= (K => 1,
L => 2,
M => 3,
N => 4,
P => 5);
package Vectors_For_Test is new Minimal_Containers.Bounded_Vectors
(Index_Type => Index_Type,
Element_Type => Element_Type);
use Vectors_For_Test;
procedure Initial (Unused : in out AUnit.Test_Cases.Test_Case'Class)
is
V : Vector (Capacity => 5);
begin
Assert (Length (V) = 0, "new vector has non-zero length");
end Initial;
procedure Add_5 (Unused : in out AUnit.Test_Cases.Test_Case'Class)
is
V : Vector (Capacity => 5);
begin
for J in Element_Type loop
Append (V, J);
end loop;
Assert (Length (V) = Capacity (V), "vector has wrong length");
end Add_5;
procedure Clearing (Unused : in out AUnit.Test_Cases.Test_Case'Class)
is
V : Vector (Capacity => 5);
C : Cursor;
Unused_Element : Element_Type;
begin
for J in Element_Type loop
Append (V, J);
end loop;
C := V.First;
V.Clear;
Assert (V.Length = 0, "vector not cleared");
Unused_Element := Element (C);
Assert (False, "can use cursor on cleared vector");
exception
when Constraint_Error =>
null;
end Clearing;
procedure Too_Many (Unused : in out AUnit.Test_Cases.Test_Case'Class)
is
V : Vector (Capacity => 4);
begin
for J in Element_Type loop
Append (V, J);
Assert (Length (V) = Element_Type'Pos (J) + 1,
"vector has wrong length");
end loop;
Assert (False, "should have raised Capacity_Error");
exception
when Capacity_Error => null;
when Ada.Assertions.Assertion_Error => null;
end Too_Many;
procedure Values (Unused : in out AUnit.Test_Cases.Test_Case'Class)
is
V : Vector (Capacity => 5);
Count : Natural;
begin
Count := 0;
for J in Index_Type loop
Append (V, Element_Type'Val (Count));
Assert (Length (V) = Count_Type (Count + 1),
"vector has wrong length");
Assert (Element (V, Index_Type (Count + 1))
= Element_Type'Val (Count),
"element has wrong value (a)");
Count := Count + 1;
end loop;
Count := 0;
for J in V.Iterate loop
Assert (Element (Position => J) = Element_Type'Val (Count),
"element has wrong value (b)");
Count := Count + 1;
end loop;
declare
Count : Integer := 0;
begin
for Value of V loop
Assert (Value = Element_Type'Val (Count),
"element has wrong value (c)");
Count := Count + 1;
end loop;
end;
end Values;
procedure Finding_Index
(Unused : in out AUnit.Test_Cases.Test_Case'Class)
is
V : Vector (Capacity => 5);
begin
for J in Index_Type range 1 .. 4 loop
Append (V, Expected_Values (J));
Assert (Length (V) = Index_Type'Pos (J),
"vector has wrong length");
Assert (Element (V, J) = Expected_Values (J),
"element has wrong value (a)");
end loop;
for J in Element_Type range L .. N loop
Assert (Find_Index (V, J) = Index_For (J),
"find_index found wrong index");
end loop;
Assert (Find_Index (V, P) = No_Index,
"find_index succeeded for missing element");
end Finding_Index;
procedure Out_Of_Range (Unused : in out AUnit.Test_Cases.Test_Case'Class)
is
V : Vector (Capacity => 5);
begin
for J in Element_Type range K .. N loop
Append (V, J);
end loop;
declare
Unused : Element_Type;
begin
Unused := Element (V, 5);
Assert (False, "should have raised Constraint_Error");
exception
when Constraint_Error => null;
end;
end Out_Of_Range;
procedure Tampering_Forward
(Unused : in out AUnit.Test_Cases.Test_Case'Class)
is
V : Vector (Capacity => 5);
begin
for J in Element_Type range K .. P loop
Append (V, J);
end loop;
for Cursor in V.Iterate loop
if Element (Cursor) = M then
declare
Cursor_Copy : Vectors_For_Test.Cursor := Cursor;
begin
V.Delete (Cursor_Copy);
end;
end if;
end loop;
Assert (False, "tampering check (forward) should have failed");
exception
when Program_Error =>
null;
end Tampering_Forward;
procedure Tampering_Reverse
(Unused : in out AUnit.Test_Cases.Test_Case'Class)
is
V : Vector (Capacity => 5);
begin
for J in Element_Type range K .. P loop
Append (V, J);
end loop;
for Cursor in reverse V.Iterate loop
if Element (Cursor) = M then
declare
Cursor_Copy : Vectors_For_Test.Cursor := Cursor;
begin
V.Delete (Cursor_Copy);
end;
end if;
end loop;
Assert (False, "tampering check (reverse) should have failed");
exception
when Program_Error =>
null;
end Tampering_Reverse;
procedure Deleting_In_Loop
(Unused : in out AUnit.Test_Cases.Test_Case'Class)
is
V : Vector (Capacity => 5);
begin
for J in Element_Type range K .. P loop
Append (V, J);
end loop;
for Index in reverse V.First_Index .. V.Last_Index loop
if V.Element (Index) = M then
V.Delete (Index);
end if;
end loop;
Assert (V.Length = 4, "wrong length");
Assert (V.Element (2) = L, "wrong element (2)");
Assert (V.Element (3) = N, "wrong element (3)");
end Deleting_In_Loop;
procedure Sorting
(Unused : in out AUnit.Test_Cases.Test_Case'Class)
is
V : Vector (Capacity => 5);
V_Copy : Vector (Capacity => 5);
package Sort_Forward
is new Vectors_For_Test.Generic_Sorting ("<" => "<");
package Sort_Reverse
is new Vectors_For_Test.Generic_Sorting ("<" => ">");
begin
-- This loop leaves the last element slot unfilled.
for El in Element_Type range K .. N loop
Append (V, El);
end loop;
V_Copy := V;
Assert (Sort_Forward.Is_Sorted (V), "should be sorted (a)");
Assert (not Sort_Reverse.Is_Sorted (V), "should not be sorted (a)");
Sort_Forward.Sort (V);
Assert (V = V_Copy, "sorted Vector /= copy (a)");
Sort_Reverse.Sort (V);
Assert (V.Element (1) = N, "wrong element (1)");
Assert (V.Element (2) = M, "wrong element (2)");
Assert (V.Element (3) = L, "wrong element (3)");
Assert (V.Element (4) = K, "wrong element (4)");
Assert (not Sort_Forward.Is_Sorted (V), "should not be sorted (b)");
Assert (Sort_Reverse.Is_Sorted (V), "should be sorted (b)");
Sort_Forward.Sort (V);
Assert (Sort_Forward.Is_Sorted (V), "should be sorted (c)");
Assert (not Sort_Reverse.Is_Sorted (V), "should not be sorted (c)");
Assert (V = V_Copy, "sorted Vector /= copy (b)");
end Sorting;
overriding procedure Register_Tests (C : in out T)
is
begin
Registration.Register_Routine
(C, Initial'Access, "initial");
Registration.Register_Routine
(C, Add_5'Access, "add 5");
Registration.Register_Routine
(C, Clearing'Access, "clearing");
Registration.Register_Routine
(C, Too_Many'Access, "add too many");
Registration.Register_Routine
(C, Values'Access, "values, loops");
Registration.Register_Routine
(C, Finding_Index'Access, "find_index");
Registration.Register_Routine
(C, Out_Of_Range'Access, "out-of-range access");
Registration.Register_Routine
(C, Tampering_Forward'Access, "tampering (forward) detected");
Registration.Register_Routine
(C, Tampering_Reverse'Access, "tampering (reverse) detected");
Registration.Register_Routine
(C, Deleting_In_Loop'Access, "deleting in loop");
Registration.Register_Routine
(C, Sorting'Access, "sorting");
end Register_Tests;
end Tests;
function Suite return AUnit.Test_Suites.Access_Test_Suite is
Result : constant AUnit.Test_Suites.Access_Test_Suite
:= new AUnit.Test_Suites.Test_Suite;
begin
AUnit.Test_Suites.Add_Test (Result, new Tests.T);
return Result;
end Suite;
end Vectors_Tests;
|