|
111
|
1 -- C3A2A02.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, for X'Access of a general access type A, Program_Error is
|
|
|
28 -- raised if the accessibility level of X is deeper than that of A.
|
|
|
29 -- Check for cases where X'Access occurs in an instance body, and A
|
|
|
30 -- is a type either declared inside the instance, or declared outside
|
|
|
31 -- the instance but not passed as an actual during instantiation.
|
|
|
32 --
|
|
|
33 -- TEST DESCRIPTION:
|
|
|
34 -- In order to satisfy accessibility requirements, the designated
|
|
|
35 -- object X must be at the same or a less deep nesting level than the
|
|
|
36 -- general access type A -- X must "live" as long as A. Nesting
|
|
|
37 -- levels are the run-time nestings of masters: block statements;
|
|
|
38 -- subprogram, task, and entry bodies; and accept statements. Packages
|
|
|
39 -- are invisible to accessibility rules.
|
|
|
40 --
|
|
|
41 -- This test declares three generic packages:
|
|
|
42 --
|
|
|
43 -- (1) One in which X is of a formal tagged derived type and declared
|
|
|
44 -- in the body, A is a type declared outside the instance, and
|
|
|
45 -- X'Access occurs in the declarative part of a nested subprogram.
|
|
|
46 --
|
|
|
47 -- (2) One in which X is a formal object of a tagged type, A is a
|
|
|
48 -- type declared outside the instance, and X'Access occurs in the
|
|
|
49 -- declarative part of the body.
|
|
|
50 --
|
|
|
51 -- (3) One in which there are two X's and two A's. In the first pair,
|
|
|
52 -- X is a formal in object of a tagged type, A is declared in the
|
|
|
53 -- specification, and X'Access occurs in the declarative part of
|
|
|
54 -- the body. In the second pair, X is of a formal derived type,
|
|
|
55 -- X and A are declared in the specification, and X'Access occurs
|
|
|
56 -- in the sequence of statements of the body.
|
|
|
57 --
|
|
|
58 -- The test verifies the following:
|
|
|
59 --
|
|
|
60 -- For (1), Program_Error is raised when the nested subprogram is
|
|
|
61 -- called, if the generic package is instantiated at a deeper level
|
|
|
62 -- than that of A. The exception is propagated to the innermost
|
|
|
63 -- enclosing master. Also, check that Program_Error is not raised
|
|
|
64 -- if the instantiation is at the same level as that of A.
|
|
|
65 --
|
|
|
66 -- For (2), Program_Error is raised upon instantiation if the object
|
|
|
67 -- passed as an actual during instantiation has an accessibility level
|
|
|
68 -- deeper than that of A. The exception is propagated to the innermost
|
|
|
69 -- enclosing master. Also, check that Program_Error is not raised if
|
|
|
70 -- the level of the actual object is not deeper than that of A.
|
|
|
71 --
|
|
|
72 -- For (3), Program_Error is not raised, for actual objects at
|
|
|
73 -- various accessibility levels (since A will have at least the same
|
|
|
74 -- accessibility level as X in all cases, no exception should ever
|
|
|
75 -- be raised).
|
|
|
76 --
|
|
|
77 -- TEST FILES:
|
|
|
78 -- The following files comprise this test:
|
|
|
79 --
|
|
|
80 -- F3A2A00.A
|
|
|
81 -- -> C3A2A02.A
|
|
|
82 --
|
|
|
83 --
|
|
|
84 -- CHANGE HISTORY:
|
|
|
85 -- 12 May 95 SAIC Initial prerelease version.
|
|
|
86 -- 10 Jul 95 SAIC Modified code to avoid dead variable optimization.
|
|
|
87 -- 26 Jun 98 EDS Added pragma Elaborate (C3A2A02_0) to package
|
|
|
88 -- package C3A2A02_3, in order to avoid possible
|
|
|
89 -- instantiation error.
|
|
|
90 --!
|
|
|
91
|
|
|
92 with F3A2A00;
|
|
|
93 generic
|
|
|
94 type FD is new F3A2A00.Tagged_Type with private;
|
|
|
95 package C3A2A02_0 is
|
|
|
96 procedure Proc;
|
|
|
97 end C3A2A02_0;
|
|
|
98
|
|
|
99
|
|
|
100 --==================================================================--
|
|
|
101
|
|
|
102
|
|
|
103 with Report;
|
|
|
104 package body C3A2A02_0 is
|
|
|
105 X : aliased FD;
|
|
|
106
|
|
|
107 procedure Proc is
|
|
|
108 Ptr : F3A2A00.AccTagClass_L0 := X'Access;
|
|
|
109 begin
|
|
|
110 -- Avoid optimization (dead variable removal of Ptr):
|
|
|
111
|
|
|
112 if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
|
|
|
113 Report.Failed ("Unexpected error in Proc");
|
|
|
114 end if;
|
|
|
115 end Proc;
|
|
|
116 end C3A2A02_0;
|
|
|
117
|
|
|
118
|
|
|
119 --==================================================================--
|
|
|
120
|
|
|
121
|
|
|
122 with F3A2A00;
|
|
|
123 generic
|
|
|
124 FObj : in out F3A2A00.Tagged_Type;
|
|
|
125 package C3A2A02_1 is
|
|
|
126 procedure Dummy; -- Needed to allow package body.
|
|
|
127 end C3A2A02_1;
|
|
|
128
|
|
|
129
|
|
|
130 --==================================================================--
|
|
|
131
|
|
|
132
|
|
|
133 with Report;
|
|
|
134 package body C3A2A02_1 is
|
|
|
135 Ptr : F3A2A00.AccTag_L0 := FObj'Access;
|
|
|
136
|
|
|
137 procedure Dummy is
|
|
|
138 begin
|
|
|
139 null;
|
|
|
140 end Dummy;
|
|
|
141 begin
|
|
|
142 -- Avoid optimization (dead variable removal of Ptr):
|
|
|
143
|
|
|
144 if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
|
|
|
145 Report.Failed ("Unexpected error in C3A2A02_1 instance");
|
|
|
146 end if;
|
|
|
147 end C3A2A02_1;
|
|
|
148
|
|
|
149
|
|
|
150 --==================================================================--
|
|
|
151
|
|
|
152
|
|
|
153 with F3A2A00;
|
|
|
154 generic
|
|
|
155 type FD is new F3A2A00.Array_Type;
|
|
|
156 FObj : in F3A2A00.Tagged_Type;
|
|
|
157 package C3A2A02_2 is
|
|
|
158 type GAF is access all FD;
|
|
|
159 type GAO is access constant F3A2A00.Tagged_Type;
|
|
|
160 XG : aliased FD;
|
|
|
161 PtrF : GAF;
|
|
|
162 Index : Integer := FD'First;
|
|
|
163
|
|
|
164 procedure Dummy; -- Needed to allow package body.
|
|
|
165 end C3A2A02_2;
|
|
|
166
|
|
|
167
|
|
|
168 --==================================================================--
|
|
|
169
|
|
|
170
|
|
|
171 with Report;
|
|
|
172 package body C3A2A02_2 is
|
|
|
173 PtrO : GAO := FObj'Access;
|
|
|
174
|
|
|
175 procedure Dummy is
|
|
|
176 begin
|
|
|
177 null;
|
|
|
178 end Dummy;
|
|
|
179 begin
|
|
|
180 PtrF := XG'Access;
|
|
|
181
|
|
|
182 -- Avoid optimization (dead variable removal of PtrO and/or PtrF):
|
|
|
183
|
|
|
184 if not Report.Equal (PtrO.C, PtrO.C) then -- Always false.
|
|
|
185 Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrO");
|
|
|
186 end if;
|
|
|
187
|
|
|
188 if not Report.Equal (PtrF(Index).C, PtrF(Index).C) then -- Always false.
|
|
|
189 Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrF");
|
|
|
190 end if;
|
|
|
191 end C3A2A02_2;
|
|
|
192
|
|
|
193
|
|
|
194 --==================================================================--
|
|
|
195
|
|
|
196
|
|
|
197 -- The instantiation of C3A2A02_0 should NOT result in any exceptions.
|
|
|
198
|
|
|
199 with F3A2A00;
|
|
|
200 with C3A2A02_0;
|
|
|
201 pragma Elaborate (C3A2A02_0);
|
|
|
202 package C3A2A02_3 is new C3A2A02_0 (F3A2A00.Tagged_Type);
|
|
|
203
|
|
|
204
|
|
|
205 --==================================================================--
|
|
|
206
|
|
|
207
|
|
|
208 with F3A2A00;
|
|
|
209 with C3A2A02_0;
|
|
|
210 with C3A2A02_1;
|
|
|
211 with C3A2A02_2;
|
|
|
212 with C3A2A02_3;
|
|
|
213
|
|
|
214 with Report;
|
|
|
215 procedure C3A2A02 is
|
|
|
216 begin -- C3A2A02. -- [ Level = 1 ]
|
|
|
217
|
|
|
218 Report.Test ("C3A2A02", "Run-time accessibility checks: instance " &
|
|
|
219 "bodies. Type of X'Access is local or global to instance");
|
|
|
220
|
|
|
221
|
|
|
222 SUBTEST1:
|
|
|
223 declare -- [ Level = 2 ]
|
|
|
224 Result1 : F3A2A00.TC_Result_Kind;
|
|
|
225 Result2 : F3A2A00.TC_Result_Kind;
|
|
|
226 begin -- SUBTEST1.
|
|
|
227
|
|
|
228 declare -- [ Level = 3 ]
|
|
|
229 package Pack_Same_Level renames C3A2A02_3;
|
|
|
230 begin
|
|
|
231 -- The accessibility level of Pack_Same_Level.X is that of the
|
|
|
232 -- instance (0), not that of the renaming declaration. The level of
|
|
|
233 -- the type of Pack_Same_Level.X'Access (F3A2A00.AccTagClass_L0) is
|
|
|
234 -- 0. Therefore, the X'Access in Pack_Same_Level.Proc does not raise
|
|
|
235 -- an exception when the subprogram is called. The level of execution
|
|
|
236 -- of the subprogram is irrelevant:
|
|
|
237
|
|
|
238 Pack_Same_Level.Proc;
|
|
|
239 Result1 := F3A2A00.OK; -- Expected result.
|
|
|
240 exception
|
|
|
241 when Program_Error => Result1 := F3A2A00.P_E;
|
|
|
242 when others => Result1 := F3A2A00.O_E;
|
|
|
243 end;
|
|
|
244
|
|
|
245 F3A2A00.TC_Display_Results (Result1, F3A2A00.OK,
|
|
|
246 "SUBTEST #1 (same level)");
|
|
|
247
|
|
|
248
|
|
|
249 declare -- [ Level = 3 ]
|
|
|
250 -- The instantiation of C3A2A02_0 should NOT result in any
|
|
|
251 -- exceptions.
|
|
|
252
|
|
|
253 package Pack_Deeper_Level is new C3A2A02_0 (F3A2A00.Tagged_Type);
|
|
|
254 begin
|
|
|
255 -- The accessibility level of Pack_Deeper_Level.X is that of the
|
|
|
256 -- instance (3). The level of the type of Pack_Deeper_Level.X'Access
|
|
|
257 -- (F3A2A00.AccTagClass_L0) is 0. Therefore, the X'Access in
|
|
|
258 -- Pack_Deeper_Level.Proc propagates Program_Error when the
|
|
|
259 -- subprogram is called:
|
|
|
260
|
|
|
261 Pack_Deeper_Level.Proc;
|
|
|
262 Result2 := F3A2A00.OK;
|
|
|
263 exception
|
|
|
264 when Program_Error => Result2 := F3A2A00.P_E; -- Expected result.
|
|
|
265 when others => Result2 := F3A2A00.O_E;
|
|
|
266 end;
|
|
|
267
|
|
|
268 F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E,
|
|
|
269 "SUBTEST #1: deeper level");
|
|
|
270
|
|
|
271 exception
|
|
|
272 when Program_Error =>
|
|
|
273 Report.Failed ("SUBTEST #1: Program_Error incorrectly raised " &
|
|
|
274 "during instantiation of generic");
|
|
|
275 when others =>
|
|
|
276 Report.Failed ("SUBTEST #1: Unexpected exception raised " &
|
|
|
277 "during instantiation of generic");
|
|
|
278 end SUBTEST1;
|
|
|
279
|
|
|
280
|
|
|
281
|
|
|
282 SUBTEST2:
|
|
|
283 declare -- [ Level = 2 ]
|
|
|
284 Result1 : F3A2A00.TC_Result_Kind;
|
|
|
285 Result2 : F3A2A00.TC_Result_Kind;
|
|
|
286 begin -- SUBTEST2.
|
|
|
287
|
|
|
288 declare -- [ Level = 3 ]
|
|
|
289 X_L3 : F3A2A00.Tagged_Type;
|
|
|
290 begin
|
|
|
291 declare -- [ Level = 4 ]
|
|
|
292 -- The accessibility level of the actual object corresponding to
|
|
|
293 -- FObj in Pack_PE is 3. The level of the type of FObj'Access
|
|
|
294 -- (F3A2A00.AccTag_L0) is 0. Therefore, the FObj'Access in Pack_PE
|
|
|
295 -- propagates Program_Error when the instance body is elaborated:
|
|
|
296
|
|
|
297 package Pack_PE is new C3A2A02_1 (X_L3);
|
|
|
298 begin
|
|
|
299 Result1 := F3A2A00.OK;
|
|
|
300 end;
|
|
|
301 exception
|
|
|
302 when Program_Error => Result1 := F3A2A00.P_E; -- Expected result.
|
|
|
303 when others => Result1 := F3A2A00.O_E;
|
|
|
304 end;
|
|
|
305
|
|
|
306 F3A2A00.TC_Display_Results (Result1, F3A2A00.P_E,
|
|
|
307 "SUBTEST #2: deeper level");
|
|
|
308
|
|
|
309
|
|
|
310 begin -- [ Level = 3 ]
|
|
|
311 declare -- [ Level = 4 ]
|
|
|
312 -- The accessibility level of the actual object corresponding to
|
|
|
313 -- FObj in Pack_OK is 0. The level of the type of FObj'Access
|
|
|
314 -- (F3A2A00.AccTag_L0) is also 0. Therefore, the FObj'Access in
|
|
|
315 -- Pack_OK does not raise an exception when the instance body is
|
|
|
316 -- elaborated:
|
|
|
317
|
|
|
318 package Pack_OK is new C3A2A02_1 (F3A2A00.X_L0);
|
|
|
319 begin
|
|
|
320 Result2 := F3A2A00.OK; -- Expected result.
|
|
|
321 end;
|
|
|
322 exception
|
|
|
323 when Program_Error => Result2 := F3A2A00.P_E;
|
|
|
324 when others => Result2 := F3A2A00.O_E;
|
|
|
325 end;
|
|
|
326
|
|
|
327 F3A2A00.TC_Display_Results (Result2, F3A2A00.OK,
|
|
|
328 "SUBTEST #2: same level");
|
|
|
329
|
|
|
330 end SUBTEST2;
|
|
|
331
|
|
|
332
|
|
|
333
|
|
|
334 SUBTEST3:
|
|
|
335 declare -- [ Level = 2 ]
|
|
|
336 Result1 : F3A2A00.TC_Result_Kind;
|
|
|
337 Result2 : F3A2A00.TC_Result_Kind;
|
|
|
338 begin -- SUBTEST3.
|
|
|
339
|
|
|
340 declare -- [ Level = 3 ]
|
|
|
341 X_L3 : F3A2A00.Tagged_Type;
|
|
|
342 begin
|
|
|
343 declare -- [ Level = 4 ]
|
|
|
344 -- Since the accessibility level of the type of X'Access in
|
|
|
345 -- both cases within Pack_OK1 is that of the instance, and since
|
|
|
346 -- X is either passed as an actual (in which case its level will
|
|
|
347 -- not be deeper than that of the instance) or is declared within
|
|
|
348 -- the instance (in which case its level is the same as that of
|
|
|
349 -- the instance), no exception should be raised when the instance
|
|
|
350 -- body is elaborated:
|
|
|
351
|
|
|
352 package Pack_OK1 is new C3A2A02_2 (F3A2A00.Array_Type, X_L3);
|
|
|
353 begin
|
|
|
354 Result1 := F3A2A00.OK; -- Expected result.
|
|
|
355 end;
|
|
|
356 exception
|
|
|
357 when Program_Error => Result1 := F3A2A00.P_E;
|
|
|
358 when others => Result1 := F3A2A00.O_E;
|
|
|
359 end;
|
|
|
360
|
|
|
361 F3A2A00.TC_Display_Results (Result1, F3A2A00.OK,
|
|
|
362 "SUBTEST #3: 1st okay case");
|
|
|
363
|
|
|
364
|
|
|
365 declare -- [ Level = 3 ]
|
|
|
366 type My_Array is new F3A2A00.Array_Type;
|
|
|
367 begin
|
|
|
368 declare -- [ Level = 4 ]
|
|
|
369 -- Since the accessibility level of the type of X'Access in
|
|
|
370 -- both cases within Pack_OK2 is that of the instance, and since
|
|
|
371 -- X is either passed as an actual (in which case its level will
|
|
|
372 -- not be deeper than that of the instance) or is declared within
|
|
|
373 -- the instance (in which case its level is the same as that of
|
|
|
374 -- the instance), no exception should be raised when the instance
|
|
|
375 -- body is elaborated:
|
|
|
376
|
|
|
377 package Pack_OK2 is new C3A2A02_2 (My_Array, F3A2A00.X_L0);
|
|
|
378 begin
|
|
|
379 Result2 := F3A2A00.OK; -- Expected result.
|
|
|
380 end;
|
|
|
381 exception
|
|
|
382 when Program_Error => Result2 := F3A2A00.P_E;
|
|
|
383 when others => Result2 := F3A2A00.O_E;
|
|
|
384 end;
|
|
|
385
|
|
|
386 F3A2A00.TC_Display_Results (Result2, F3A2A00.OK,
|
|
|
387 "SUBTEST #3: 2nd okay case");
|
|
|
388
|
|
|
389
|
|
|
390 end SUBTEST3;
|
|
|
391
|
|
|
392
|
|
|
393
|
|
|
394 Report.Result;
|
|
|
395
|
|
|
396 end C3A2A02;
|
