1-- C360002.A
2--
3--                             Grant of Unlimited Rights
4--
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
14--     to do so.
15--
16--                                    DISCLAIMER
17--
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.
24--*
25--
26-- OBJECTIVE:
27--      Check that modular types may be used as array indices.
28--
29--      Check that if aliased appears in the component_definition of an
30--      array_type that each component of the array is aliased.
31--
32--      Check that references to aliased array objects produce correct
33--      results, and that out-of-bounds indexing correctly produces
34--      Constraint_Error.
35--
36-- TEST DESCRIPTION:
37--      This test defines several array types and subtypes indexed by modular
38--      types; some aliased some not, some with aliased components, some not.
39--
40--      It then checks that assignments move the correct data.
41--
42--
43-- CHANGE HISTORY:
44--      28 SEP 95   SAIC   Initial version
45--      23 APR 96   SAIC   Doc fixes, fixed constrained/unconstrained conflict
46--      13 FEB 97   PWB.CTA Removed illegal declarations and affected code
47--!
48
49------------------------------------------------------------------- C360002
50
51with Report;
52
53procedure C360002 is
54
55  Verbose : Boolean := Report.Ident_Bool( False );
56
57  type Mod_128 is mod 128;
58
59  function Ident_128( I: Integer ) return Mod_128 is
60  begin
61    return Mod_128( Report.Ident_Int( I ) );
62  end Ident_128;
63
64  type Unconstrained_Array
65       is array( Mod_128 range <> ) of Integer;
66
67  type Unconstrained_Array_Aliased
68       is array( Mod_128 range <> ) of aliased Integer;
69
70  type Access_All_Unconstrained_Array
71       is access all Unconstrained_Array;
72
73  type Access_All_Unconstrained_Array_Aliased
74       is access all Unconstrained_Array_Aliased;
75
76  subtype Array_01_10
77          is Unconstrained_Array(01..10);
78
79  subtype Array_11_20
80          is Unconstrained_Array(11..20);
81
82  subtype Array_Aliased_01_10
83          is Unconstrained_Array_Aliased(01..10);
84
85  subtype Array_Aliased_11_20
86          is Unconstrained_Array_Aliased(11..20);
87
88  subtype Access_All_01_10_Array
89          is Access_All_Unconstrained_Array(01..10);
90
91  subtype Access_All_01_10_Array_Aliased
92          is Access_All_Unconstrained_Array_Aliased(01..10);
93
94  subtype Access_All_11_20_Array
95          is Access_All_Unconstrained_Array(11..20);
96
97  subtype Access_All_11_20_Array_Aliased
98          is Access_All_Unconstrained_Array_Aliased(11..20);
99
100
101-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
102
103  -- these 'filler' functions create unique values for every element that
104  -- is used and/or tested in this test.
105
106  Well_Bottom : Integer := 0;
107
108  function Filler( Size : Mod_128 ) return Unconstrained_Array is
109    It : Unconstrained_Array( 0..Size-1 );
110  begin
111    for Eyes in It'Range loop
112      It(Eyes) := Integer( Eyes ) + Well_Bottom;
113    end loop;
114    Well_Bottom := Well_Bottom + It'Length;
115    return It;
116  end Filler;
117
118  function Filler( Size : Mod_128 ) return Unconstrained_Array_Aliased is
119    It : Unconstrained_Array_Aliased( 0..Size-1 );
120  begin
121    for Ayes in It'Range loop
122      It(Ayes) := Integer( Ayes ) + Well_Bottom;
123    end loop;
124    Well_Bottom := Well_Bottom + It'Length;
125    return It;
126  end Filler;
127
128-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
129
130  An_Integer : Integer;
131
132  type AAI is access all Integer;
133
134  An_Integer_Access : AAI;
135
136  Array_Item_01_10 : Array_01_10 := Filler(10); -- 0..9
137
138  Array_Item_11_20 : Array_11_20 := Filler(10); -- 10..19 (sliding)
139
140  Array_Aliased_Item_01_10 : Array_Aliased_01_10 := Filler(10); -- 20..29
141
142  Array_Aliased_Item_11_20 : Array_Aliased_11_20 := Filler(10); -- 30..39
143
144  Aliased_Array_Item_01_10 : aliased Array_01_10 := Filler(10); -- 40..49
145
146  Aliased_Array_Item_11_20 : aliased Array_11_20 := Filler(10); -- 50..59
147
148  Aliased_Array_Aliased_Item_01_10 : aliased Array_Aliased_01_10
149                                   := Filler(10);               -- 60..69
150
151  Aliased_Array_Aliased_Item_11_20 : aliased Array_Aliased_11_20
152                                   := Filler(10);               -- 70..79
153
154  Check_Item            : Access_All_Unconstrained_Array;
155
156  Check_Aliased_Item    : Access_All_Unconstrained_Array_Aliased;
157
158-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
159
160  procedure Fail( Message : String; CI, SB : Integer ) is
161  begin
162    Report.Failed("Wrong value passed " & Message);
163    if Verbose then
164      Report.Comment("got" & Integer'Image(CI) &
165                     " should be" & Integer'Image(SB) );
166    end if;
167  end Fail;
168
169  procedure Check_Array_01_10( Checked_Item : Array_01_10;
170                               Low_SB       : Integer ) is
171  begin
172    for Index in Checked_Item'Range loop
173      if (Checked_Item(Index) /= (Low_SB +Integer(Index)-1)) then
174        Fail("unaliased 1..10", Checked_Item(Index),
175                                (Low_SB +Integer(Index)-1));
176      end if;
177    end loop;
178  end Check_Array_01_10;
179
180  procedure Check_Array_11_20( Checked_Item : Array_11_20;
181                               Low_SB       : Integer ) is
182  begin
183    for Index in Checked_Item'Range loop
184      if (Checked_Item(Index) /= (Low_SB +Integer(Index)-11)) then
185        Fail("unaliased 11..20", Checked_Item(Index),
186                                 (Low_SB +Integer(Index)-11));
187      end if;
188    end loop;
189 end Check_Array_11_20;
190
191  procedure Check_Single_Integer( The_Integer, SB : Integer;
192                                  Message         : String ) is
193  begin
194    if The_Integer /= SB then
195      Report.Failed("Wrong integer value for " & Message );
196    end if;
197  end Check_Single_Integer;
198
199-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
200
201begin  -- Main test procedure.
202
203  Report.Test ("C360002", "Check that modular types may be used as array " &
204                          "indices.  Check that if aliased appears in " &
205                          "the component_definition of an array_type that " &
206                          "each component of the array is aliased.  Check " &
207                          "that references to aliased array objects " &
208                          "produce correct results, and that out of bound " &
209                          "references to aliased objects correctly " &
210                          "produce Constraint_Error" );
211  -- start with checks that the Filler assignments produced the expected
212  -- result.  This is a "case 0" test to check that nothing REALLY surprising
213  -- is happening
214
215  Check_Array_01_10( Array_Item_01_10, 0 );
216  Check_Array_11_20( Array_Item_11_20, 10 );
217
218  -- check that having the variable aliased makes no difference
219  Check_Array_01_10( Aliased_Array_Item_01_10, 40 );
220  Check_Array_11_20( Aliased_Array_Item_11_20, 50 );
221
222  -- now check that conversion between array types where the only
223  -- difference in the definitions is that the components are aliased works
224
225  Check_Array_01_10( Unconstrained_Array( Array_Aliased_Item_01_10 ), 20 );
226  Check_Array_11_20( Unconstrained_Array( Array_Aliased_Item_11_20 ), 30 );
227
228  -- check that conversion of an aliased object with aliased components
229  -- also works
230
231  Check_Array_01_10( Unconstrained_Array( Aliased_Array_Aliased_Item_01_10 ),
232                     60 );
233  Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ),
234                     70 );
235
236  -- check that the bounds will slide
237
238  Check_Array_01_10( Array_01_10( Array_Item_11_20 ), 10 );
239  Check_Array_11_20( Array_11_20( Array_Item_01_10 ),  0 );
240
241  -- point at some of the components and check them
242
243  An_Integer_Access := Array_Aliased_Item_01_10(5)'Access;
244
245  Check_Single_Integer( An_Integer_Access.all, 24,
246                       "Aliased component 'Access");
247
248  An_Integer_Access := Aliased_Array_Aliased_Item_01_10(7)'Access;
249
250  Check_Single_Integer( An_Integer_Access.all, 66,
251                       "Aliased Aliased component 'Access");
252
253  -- check some assignments
254
255  Array_Item_01_10 := Aliased_Array_Item_01_10;
256  Check_Array_01_10( Array_Item_01_10, 40 );
257
258  Aliased_Array_Item_01_10 := Aliased_Array_Item_11_20(11..20);
259  Check_Array_01_10( Aliased_Array_Item_01_10, 50 );
260
261  Aliased_Array_Aliased_Item_11_20(11..20)
262                                       := Aliased_Array_Aliased_Item_01_10;
263  Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ),
264                     60 );
265
266  Report.Result;
267
268end C360002;
269