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
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
|
-- TCTouch.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- FOUNDATION DESCRIPTION:
-- The tools in this foundation are not peculiar to any particular
-- aspect of the language, but simplify the test writing and reading
-- process. Assert and Assert_Not are used to reduce the textual
-- overhead of the test-that-this-condition-is-(not)-true paradigm.
-- Touch and Validate are used to simplify tracing an expected path
-- of execution.
-- A tag comment of the form:
--
-- TCTouch.Touch( 'A' ); ----------------------------------------- A
--
-- is recommended to improve readability of this feature.
--
-- Report.Test must be called before any of the procedures in this
-- package with the exception of Touch.
-- The usage paradigm is to call Touch in locations in the test where you
-- want a trace of execution. Each call to Touch should have a unique
-- character associated with it. At each place where a check can
-- reasonably be performed to determine correct execution of a
-- sub-test, a call to Validate should be made. The first parameter
-- passed to Validate is the expected string of characters produced by
-- call(s) to Touch in the subtest just executed. The second parameter
-- is the message to pass to Report.Failed if the expected sequence was
-- not executed.
--
-- Validate should always be called after calls to Touch before a test
-- completes.
--
-- In the event that calls may have been made to Touch that are not
-- intended to be recorded, or, the failure of a previous subtest may
-- leave Touch calls "Unvalidated", the procedure Flush will reset the
-- tracker to the "empty" state. Flush does not make any calls to
-- Report.
--
-- Calls to Assert and Assert_Not are to replace the idiom:
--
-- if BadCondition then -- or if not PositiveTest then
-- Report.Failed(Message);
-- end if;
--
-- with:
--
-- Assert_Not( BadCondition, Message ); -- or
-- Assert( PositiveTest, Message );
--
-- Implementation_Check is for use with tests that cross the boundary
-- between the core and the Special Needs Annexes. There are several
-- instances where language in the core becomes enforceable only when
-- a Special Needs Annex is supported. Implementation_Check should be
-- called in place of Report.Failed in these cases; it examines the
-- constants in Impdef that indicate if the particular Special Needs
-- Annex is being validated with this validation; and acts accordingly.
--
-- The constant Foundation_ID contains the internal change version
-- for this software.
--
-- ERROR CONDITIONS:
--
-- It is an error to perform more than Max_Touch_Count (80) calls to
-- Touch without a subsequent call to Validate. To do so will cause
-- a false test failure.
--
-- CHANGE HISTORY:
-- 02 JUN 94 SAIC Initial version
-- 27 OCT 94 SAIC Revised version
-- 07 AUG 95 SAIC Added Implementation_Check
-- 07 FEB 96 SAIC Changed to match new Impdef for 2.1
-- 16 MAR 00 RLB Changed foundation id to reflect test suite version.
-- 22 MAR 01 RLB Changed foundation id to reflect test suite version.
-- 29 MAR 02 RLB Changed foundation id to reflect test suite version.
-- 06 MAR 07 RLB Changed foundation id to reflect test suite version.
-- 22 MAR 07 RLB Changed foundation id to reflect test suite version.
-- 07 SEP 07 RLB Added Validate_One_Of.
-- 23 JAN 14 RLB Changed foundation id to reflect test suite version.
-- 28 FEB 14 RLB Changed foundation id to reflect test suite version.
-- 19 MAR 18 RLB Fixed to avoid repeating the "Trace Overflow"
-- message many times if there is broken implementation
-- of something. Changed the foundation id (previously
-- missed for ACATS 4.1).
--
--!
package TCTouch is
Foundation_ID : constant String := "TCTouch ACATS 4.1";
Max_Touch_Count : constant := 80;
procedure Assert ( SB_True : Boolean; Message : String );
procedure Assert_Not( SB_False : Boolean; Message : String );
procedure Touch ( A_Tag : Character );
procedure Validate( Expected: String;
Message : String;
Order_Meaningful : Boolean := True );
procedure Validate_One_Of (Expected_1: String;
Expected_2: String;
Expected_3: String := "";
Expected_4: String := "";
Expected_5: String := "";
Expected_6: String := "";
Message : String);
-- OK if any of the expected strings is found.
-- If the null string is a legitimate result, it must be given
-- first.
procedure Flush;
type Special_Needs_Annexes is ( Annex_C, Annex_D, Annex_E,
Annex_F, Annex_G, Annex_H );
procedure Implementation_Check( Message : in String;
Annex : in Special_Needs_Annexes
:= Annex_C );
-- If Impdef.Validating_Annex_<Annex> is true, will call Report.Failed
-- otherwise will call Report.Not_Applicable. This is to allow tests
-- which are driven by wording in the core of the language, yet have
-- their functionality dictated by the Special Needs Annexes to perform
-- dual purpose.
-- The default of Annex_C for the Annex parameter is to support early
-- tests written with the assumption that Implementation_Check was
-- expressly for use with the Systems Programming Annex.
end TCTouch;
with Report;
with Impdef;
package body TCTouch is
procedure Assert( SB_True : Boolean; Message : String ) is
begin
if not SB_True then
Report.Failed( "Assertion failed: " & Message );
end if;
end Assert;
procedure Assert_Not( SB_False : Boolean; Message : String ) is
begin
if SB_False then
Report.Failed( "Assertion failed: " & Message );
end if;
end Assert_Not;
Collection : String(1..Max_Touch_Count);
Finger : Natural := 0;
Overflow_Count : Natural := 0;
procedure Touch ( A_Tag : Character ) is
begin
Finger := Finger+1;
Collection(Finger) := A_Tag;
exception
when Constraint_Error =>
if Overflow_Count = 0 then
Report.Failed("Trace Overflow: " & Collection);
end if;
if Overflow_Count <= Natural'Last - Max_Touch_Count then
Overflow_Count := Overflow_Count + Max_Touch_Count;
-- else the overflow count would overflow. :-)
end if;
Finger := 0;
end Touch;
procedure Sort_String( S: in out String ) is
-- algorithm from Booch Components Page 472
No_Swaps : Boolean;
procedure Swap(C1, C2: in out Character) is
T: Character := C1;
begin C1 := C2; C2 := T; end Swap;
begin
for OI in S'First+1..S'Last loop
No_Swaps := True;
for II in reverse OI..S'Last loop
if S(II) < S(II-1) then
Swap(S(II),S(II-1));
No_Swaps := False;
end if;
end loop;
exit when No_Swaps;
end loop;
end Sort_String;
procedure Check_Overflow is
-- Check and report on any overflow, clearing the overflow information
-- afterwards.
begin
if Overflow_Count > Max_Touch_Count then
if Overflow_Count > Natural'Last - Max_Touch_Count then
Report.Comment ("More than " & Natural'Image(Overflow_Count) &
" excess Touch calls discarded");
else
Report.Comment (Natural'Image(Overflow_Count) &
" excess Touch calls discarded");
end if;
end if;
Overflow_Count := 0;
end Check_Overflow;
procedure Validate( Expected: String;
Message : String;
Order_Meaningful : Boolean := True) is
Want : String(1..Expected'Length) := Expected;
begin
Check_Overflow;
if not Order_Meaningful then
Sort_String( Want );
Sort_String( Collection(1..Finger) );
end if;
if Collection(1..Finger) /= Want then
Report.Failed( Message & " Expecting: " & Want
& " Got: " & Collection(1..Finger) );
end if;
Finger := 0;
end Validate;
procedure Validate_One_Of (Expected_1: String;
Expected_2: String;
Expected_3: String := "";
Expected_4: String := "";
Expected_5: String := "";
Expected_6: String := "";
Message : String) is
-- OK if any of the expected strings is found.
-- If the null string is a legitimate result, it must be given
-- first.
begin
Check_Overflow;
if Collection(1..Finger) = Expected_1 then
Finger := 0;
return; -- OK.
elsif Collection(1..Finger) = Expected_2 then
Finger := 0;
return; -- OK.
elsif Expected_3 /= "" and then Collection(1..Finger) = Expected_3 then
Finger := 0;
return; -- OK.
elsif Expected_4 /= "" and then Collection(1..Finger) = Expected_4 then
Finger := 0;
return; -- OK.
elsif Expected_5 /= "" and then Collection(1..Finger) = Expected_5 then
Finger := 0;
return; -- OK.
elsif Expected_6 /= "" and then Collection(1..Finger) = Expected_6 then
Finger := 0;
return; -- OK.
else
if Expected_3 = "" and Expected_4 = "" and
Expected_5 = "" and Expected_6 = "" then
Report.Failed( Message & " Expecting: " & Expected_1
& " or: " & Expected_2
& " but got: " & Collection(1..Finger) );
elsif Expected_4 = "" and
Expected_5 = "" and Expected_6 = "" then
Report.Failed( Message & " Expecting: " & Expected_1
& " or: " & Expected_2
& " or: " & Expected_3
& " but got: " & Collection(1..Finger) );
elsif Expected_5 = "" and Expected_6 = "" then
Report.Failed( Message & " Expecting: " & Expected_1
& " or: " & Expected_2
& " or: " & Expected_3
& " or: " & Expected_4
& " but got: " & Collection(1..Finger) );
elsif Expected_6 = "" then
Report.Failed( Message & " Expecting: " & Expected_1
& " or: " & Expected_2
& " or: " & Expected_3
& " or: " & Expected_4
& " or: " & Expected_5
& " but got: " & Collection(1..Finger) );
else
Report.Failed( Message & " Expecting: " & Expected_1
& " or: " & Expected_2
& " or: " & Expected_3
& " or: " & Expected_4
& " or: " & Expected_5
& " or: " & Expected_6
& " but got: " & Collection(1..Finger) );
end if;
Finger := 0;
end if;
end Validate_One_Of;
procedure Flush is
begin
Finger := 0;
end Flush;
procedure Implementation_Check( Message : in String;
Annex : in Special_Needs_Annexes
:= Annex_C ) is
-- default to cover some legacy
-- USAGE DISCIPLINE:
-- Implementation_Check is designed to be used in tests that have
-- interdependency on one of the Special Needs Annexes, yet are _really_
-- tests based in the core language. There will be instances where the
-- execution of a test would be failing in the light of the requirements
-- of the annex, yet from the point of view of the core language without
-- the additional requirements of the annex, the test does not apply.
-- In these cases, rather than issuing a call to Report.Failed, calling
-- TCTouch.Implementation_Check will check that sensitivity, and if
-- the implementation is attempting to validate against the specific
-- annex, Report.Failed will be called, otherwise, Report.Not_Applicable
-- will be called.
begin
case Annex is
when Annex_C =>
if ImpDef.Validating_Annex_C then
Report.Failed( Message );
else
Report.Not_Applicable( Message & " Annex C not supported" );
end if;
when Annex_D =>
if ImpDef.Validating_Annex_D then
Report.Failed( Message );
else
Report.Not_Applicable( Message & " Annex D not supported" );
end if;
when Annex_E =>
if ImpDef.Validating_Annex_E then
Report.Failed( Message );
else
Report.Not_Applicable( Message & " Annex E not supported" );
end if;
when Annex_F =>
if ImpDef.Validating_Annex_F then
Report.Failed( Message );
else
Report.Not_Applicable( Message & " Annex F not supported" );
end if;
when Annex_G =>
if ImpDef.Validating_Annex_G then
Report.Failed( Message );
else
Report.Not_Applicable( Message & " Annex G not supported" );
end if;
when Annex_H =>
if ImpDef.Validating_Annex_H then
Report.Failed( Message );
else
Report.Not_Applicable( Message & " Annex H not supported" );
end if;
end case;
end Implementation_Check;
end TCTouch;
|
