3 -- Grant of Unlimited Rights
5 -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6 -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7 -- unlimited rights in the software and documentation contained herein.
8 -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
9 -- this public release, the Government intends to confer upon all
10 -- recipients unlimited rights equal to those held by the Government.
11 -- These rights include rights to use, duplicate, release or disclose the
12 -- released technical data and computer software in whole or in part, in
13 -- any manner and for any purpose whatsoever, and to have or permit others
18 -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19 -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20 -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21 -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22 -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23 -- PARTICULAR PURPOSE OF SAID MATERIAL.
27 -- Check that actual parameters passed by reference are view converted
28 -- to the nominal subtype of the formal parameter.
31 -- Check that sliding is allowed for formal parameters, especially
32 -- check cases that would have caused errors in Ada'83.
33 -- Check that length check for a formal parameter (esp out mode)
34 -- is performed before the call, not after.
36 -- notes: 6.2; by reference ::= tagged, task, protected,
37 -- limited (nonprivate), or composite containing such
38 -- 4.6; view conversion
42 -- 26 JAN 96 SAIC Initial version
43 -- 04 NOV 96 SAIC Commentary revision for release 2.1
44 -- 27 FEB 97 PWB.CTA Corrected reference to the wrong string
47 ----------------------------------------------------------------- C641001_0
51 subtype String_10
is String(1..10);
53 procedure Check_String_10
( S
: out String_10
; Start
, Stop
: Natural );
55 procedure Check_Illegal_Slice_Reference
( Slice_Passed
: in out String;
58 type Tagged_Data
(Bound
: Natural) is tagged record
59 Data_Item
: String(1..Bound
) := (others => '*');
62 type Tag_List
is array(Natural range <>) of Tagged_Data
(5);
64 subtype Tag_List_10
is Tag_List
(1..10);
66 procedure Check_Tag_Slice
( TL
: in out Tag_List_10
);
68 procedure Check_Out_Tagged_Data
( Formal
: out Tagged_Data
);
72 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
76 package body C641001_0
is
78 String_Data
: constant String := "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ";
80 procedure Check_String_10
( S
: out String_10
; Start
, Stop
: Natural ) is
82 if S
'Length /= 10 then
83 Report
.Failed
("Length check not performed prior to execution");
85 S
:= String_Data
(Start
..Stop
);
87 when others => Report
.Failed
("Exception encountered in Check_String_10");
90 procedure Check_Illegal_Slice_Reference
( Slice_Passed
: in out String;
93 -- essentially "do-nothing" for optimization foilage...
94 if Slice_Passed
(Index
) in Character then
95 -- Intent is ^^^^^ should raise Constraint_Error
96 Report
.Failed
("Illegal Slice provided legal character");
98 Report
.Failed
("Illegal Slice provided illegal character");
101 when Constraint_Error
=>
102 null; -- expected case
104 Report
.Failed
("Wrong exception in Check_Illegal_Slice_Reference");
105 end Check_Illegal_Slice_Reference
;
107 procedure Check_Tag_Slice
( TL
: in out Tag_List_10
) is
108 -- if the view conversion is not performed, one of the following checks
109 -- will fail (given data passed as 0..9 and then 2..11)
111 Check_Under_Index
: -- index 0 should raise C_E
113 TCTouch
.Assert
( TL
(Report
.Ident_Int
(0)).Data_Item
= "*****",
114 "Index 0 (illegal); bad data" );
115 Report
.Failed
("Index 0 did not raise Constraint_Error");
117 when Constraint_Error
=>
118 null; -- expected case
120 Report
.Failed
("Wrong exception in Check_Under_Index ");
121 end Check_Under_Index
;
123 Check_Over_Index
: -- index 11 should raise C_E
125 TCTouch
.Assert
( TL
(Report
.Ident_Int
(11)).Data_Item
= "*****",
126 "Index 11 (illegal); bad data" );
127 Report
.Failed
("Index 11 did not raise Constraint_Error");
129 when Constraint_Error
=>
130 null; -- expected case
132 Report
.Failed
("Wrong exception in Check_Over_Index ");
133 end Check_Over_Index
;
137 procedure Check_Out_Tagged_Data
( Formal
: out Tagged_Data
) is
139 TCTouch
.Assert
( Formal
.Data_Item
= "*****", "out formal data bad" );
140 Formal
.Data_Item
(1) := '!';
141 end Check_Out_Tagged_Data
;
145 ------------------------------------------------------------------- C641001
152 function II
( I
: Integer ) return Integer renames Report
.Ident_Int
;
153 -- ^^ name chosen to allow embedding in calls
155 A_String_10
: C641001_0
.String_10
;
156 Slicable
: String(1..40);
157 Tag_Slices
: C641001_0
.Tag_List
(0..11);
159 Global_Data
: String(1..26) := "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
161 procedure Check_Out_Sliding
( Lo1
, Hi1
, Lo2
, Hi2
: Natural ) is
163 subtype One_Constrained_String
is String(Lo1
..Hi1
); -- 1 5
164 subtype Two_Constrained_String
is String(Lo2
..Hi2
); -- 6 10
166 procedure Out_Param
( Param
: out One_Constrained_String
) is
168 Param
:= Report
.Ident_Str
( Global_Data
(Lo2
..Hi2
) );
170 Object
: Two_Constrained_String
;
173 if Object
/= Report
.Ident_Str
( Global_Data
(Lo2
..Hi2
) ) then
174 Report
.Failed
("Bad result in Check_Out_Sliding");
177 when others => Report
.Failed
("Exception in Check_Out_Sliding");
178 end Check_Out_Sliding
;
180 procedure Check_Dynamic_Subtype_Cases
(F_Lower
,F_Upper
: Natural;
181 A_Lower
,A_Upper
: Natural) is
183 subtype Dyn_String
is String(F_Lower
..F_Upper
);
185 procedure Check_Dyn_Subtype_Formal_Out
( Param
: out Dyn_String
) is
187 Param
:= Global_Data
(11..20);
188 end Check_Dyn_Subtype_Formal_Out
;
190 procedure Check_Dyn_Subtype_Formal_In
( Param
: in Dyn_String
) is
192 if Param
/= Global_Data
(11..20) then
193 Report
.Failed
("Dynamic case, data mismatch");
195 end Check_Dyn_Subtype_Formal_In
;
197 Stuff
: String(A_Lower
..A_Upper
);
200 Check_Dyn_Subtype_Formal_Out
( Stuff
);
201 Check_Dyn_Subtype_Formal_In
( Stuff
);
202 end Check_Dynamic_Subtype_Cases
;
204 begin -- Main test procedure.
206 Report
.Test
("C641001", "Check that actual parameters passed by " &
207 "reference are view converted to the nominal " &
208 "subtype of the formal parameter" );
210 -- non error cases for string slices
212 C641001_0
.Check_String_10
( A_String_10
, 1, 10 );
213 TCTouch
.Assert
( A_String_10
= "1234567890", "Nominal case" );
215 C641001_0
.Check_String_10
( A_String_10
, 11, 20 );
216 TCTouch
.Assert
( A_String_10
= "ABCDEFGHIJ", "Sliding to subtype" );
218 C641001_0
.Check_String_10
( Slicable
(1..10), 1, 10 );
219 TCTouch
.Assert
( Slicable
(1..10) = "1234567890", "Slice, no sliding" );
221 C641001_0
.Check_String_10
( Slicable
(1..10), 21, 30 );
222 TCTouch
.Assert
( Slicable
(1..10) = "KLMNOPQRST", "Sliding to slice" );
224 C641001_0
.Check_String_10
( Slicable
(11..20), 11, 20 );
225 TCTouch
.Assert
( Slicable
(11..20) = "ABCDEFGHIJ", "Sliding to same" );
227 C641001_0
.Check_String_10
( Slicable
(21..30), 11, 20 );
228 TCTouch
.Assert
( Slicable
(21..30) = "ABCDEFGHIJ", "Sliding up" );
230 -- error cases for string slices
232 C641001_0
.Check_Illegal_Slice_Reference
( Slicable
(21..30), 20 );
234 C641001_0
.Check_Illegal_Slice_Reference
( Slicable
(1..15), Slicable
'Last );
236 -- checks for view converting actuals to formals
238 -- catch low bound fault
239 C641001_0
.Check_Tag_Slice
( Tag_Slices
(II
(0)..9) ); -- II ::= Ident_Int
240 TCTouch
.Assert
( Tag_Slices
'First = 0, "Tag_Slices'First = 0" );
241 TCTouch
.Assert
( Tag_Slices
'Last = 11, "Tag_Slices'Last = 11" );
243 -- catch high bound fault
244 C641001_0
.Check_Tag_Slice
( Tag_Slices
(2..II
(11)) );
245 TCTouch
.Assert
( Tag_Slices
'First = 0, "Tag_Slices'First = 0" );
246 TCTouch
.Assert
( Tag_Slices
'Last = 11, "Tag_Slices'Last = 11" );
248 Check_Formal_Association_Check
:
250 C641001_0
.Check_String_10
( Slicable
, 1, 10 ); -- catch length fault
251 Report
.Failed
("Exception not raised at Check_Formal_Association_Check");
253 when Constraint_Error
=>
254 null; -- expected case
256 Report
.Failed
("Wrong exception at Check_Formal_Association_Check");
257 end Check_Formal_Association_Check
;
259 -- check for constrained actual, unconstrained formal
260 C641001_0
.Check_Out_Tagged_Data
( Tag_Slices
(5) );
261 TCTouch
.Assert
( Tag_Slices
(5).Data_Item
= "!****",
262 "formal out returned bad result" );
264 -- additional checks for out mode formal parameters, dynamic subtypes
266 Check_Out_Sliding
( II
(1),II
(5), II
(6),II
(10) );
268 Check_Out_Sliding
( 21,25, 6,10 );
270 Check_Dynamic_Subtype_Cases
(F_Lower
=> II
(1), F_Upper
=> II
(10),
271 A_Lower
=> II
(1), A_Upper
=> II
(10));
273 Check_Dynamic_Subtype_Cases
(F_Lower
=> II
(21), F_Upper
=> II
(30),
274 A_Lower
=> II
( 1), A_Upper
=> II
(10));
276 Check_Dynamic_Subtype_Cases
(F_Lower
=> II
( 1), F_Upper
=> II
(10),
277 A_Lower
=> II
(21), A_Upper
=> II
(30));