summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a
blob: 8271d4869047b9768e7ac9297009262cd90920b1 (plain)
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
-- C3A2A01.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.
--*
--
-- OBJECTIVE:
--      Check that, for X'Access of a general access type A, Program_Error is
--      raised if the accessibility level of X is deeper than that of A.
--      Check for cases where X'Access occurs in an instance body, and A
--      is passed as an actual during instantiation.
--
-- TEST DESCRIPTION:
--      In order to satisfy accessibility requirements, the designated
--      object X must be at the same or a less deep nesting level than the
--      general access type A -- X must "live" as long as A. Nesting
--      levels are the run-time nestings of masters: block statements;
--      subprogram, task, and entry bodies; and accept statements. Packages
--      are invisible to accessibility rules.
--
--      This test declares three generic units, each of which has a formal
--      general access type:
--
--         (1) A generic package, in which X is declared in the specification,
--             and X'Access occurs within the declarative part of the body.
--
--         (2) A generic package, in which X is a formal in out object of a
--             tagged formal derived type, and X'Access occurs in the sequence
--             of statements of a nested subprogram.
--
--         (3) A generic procedure, in which X is a dereference of an access
--             parameter, and X'Access occurs in the sequence of statements.
--
--      The test verifies the following:
--
--         For (1), Program_Error is raised upon instantiation if the generic
--         package is instantiated at a deeper level than that of the general
--         access type passed as an actual. The exception is propagated to the
--         innermost enclosing master.
--
--         For (2), Program_Error is raised when the nested subprogram is
--         called if the object passed as an actual during instantiation of
--         the generic package has an accessibility level deeper than that of
--         the general access type passed as an actual. The exception is
--         handled within the nested subprogram. Also, check that
--         Program_Error is not raised if the level of the actual access type
--         is deeper than that of the actual object.
--
--         For (3), Program_Error is raised when the instance subprogram is
--         called if the object pointed to by the actual corresponding to
--         the access parameter has an accessibility level deeper than that of
--         the general access type passed as an actual during instantiation.
--         The exception is handled within the instance subprogram. Also,
--         check that Program_Error is not raised if the level of the actual
--         access type is deeper than that of the actual corresponding to the
--         access parameter.
--
-- TEST FILES:
--      The following files comprise this test:
--
--         F3A2A00.A
--      -> C3A2A01.A
--
--
-- CHANGE HISTORY:
--      12 May 95   SAIC    Initial prerelease version.
--      10 Jul 95   SAIC    Modified code to avoid dead variable optimization.
--
--!

with F3A2A00;
generic
   type FD  is new F3A2A00.Array_Type;
   type FAF is access all FD;
package C3A2A01_0 is
   X : aliased FD;

   procedure Dummy;  -- Needed to allow package body.
end C3A2A01_0;


     --==================================================================--


with Report;
package body C3A2A01_0 is
   Ptr   : FAF     := X'Access;
   Index : Integer := F3A2A00.Array_Type'First;

   procedure Dummy is
   begin
      null;
   end Dummy;
begin
   -- Avoid optimization (dead variable removal of Ptr):

   if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then   -- Always false.
      Report.Failed ("Unexpected error in C3A2A01_0 instance");
   end if;
end C3A2A01_0;


     --==================================================================--


with F3A2A00;
generic
   type FD  is new F3A2A00.Tagged_Type with private;
   type FAF is access all FD;
   FObj : in out FD;
package C3A2A01_1 is
   procedure Handle (R: out F3A2A00.TC_Result_Kind);
end C3A2A01_1;


     --==================================================================--


with Report;
package body C3A2A01_1 is

   procedure Handle (R: out F3A2A00.TC_Result_Kind) is
      Ptr : FAF;
   begin
      Ptr := FObj'Access;
      R   := F3A2A00.OK;

      -- Avoid optimization (dead variable removal of Ptr):

      if not Report.Equal (Ptr.C, Ptr.C) then              -- Always false.
         Report.Failed ("Unexpected error in Handle");
      end if;
   exception
      when Program_Error => R := F3A2A00.P_E;
      when others        => R := F3A2A00.O_E;
   end Handle;

end C3A2A01_1;


     --==================================================================--


with F3A2A00;
generic
   type FD  is new F3A2A00.Array_Type;
   type FAF is access all FD;
procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind);


     --==================================================================--


with Report;
procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind) is
   Ptr   : FAF;
   Index : Integer := F3A2A00.Array_Type'First;
begin
   Ptr := P.all'Access;
   R   := F3A2A00.OK;

   -- Avoid optimization (dead variable removal of Ptr):

   if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then   -- Always false.
      Report.Failed ("Unexpected error in C3A2A01_2 instance");
   end if;
exception
   when Program_Error => R := F3A2A00.P_E;
   when others        => R := F3A2A00.O_E;
end C3A2A01_2;


     --==================================================================--


with F3A2A00;
with C3A2A01_0;
with C3A2A01_1;
with C3A2A01_2;

with Report;
procedure C3A2A01 is
begin -- C3A2A01.                                              -- [ Level = 1 ]

   Report.Test ("C3A2A01", "Run-time accessibility checks: instance " &
                "bodies. Type of X'Access is passed as actual to instance");


   SUBTEST1:
   declare                                                     -- [ Level = 2 ]
      Result : F3A2A00.TC_Result_Kind;
   begin -- SUBTEST1.

      declare                                                  -- [ Level = 3 ]
         type AccArr_L3 is access all F3A2A00.Array_Type;
      begin
         declare                                               -- [ Level = 4 ]
            -- The accessibility level of Pack.X is that of the instantiation
            -- (4). The accessibility level of the actual access type used to
            -- instantiate Pack is 3. Therefore, the X'Access in Pack
            -- propagates Program_Error when the instance body is elaborated:

            package Pack is new C3A2A01_0 (F3A2A00.Array_Type, AccArr_L3);
         begin
            Result := F3A2A00.OK;
         end;
      exception
         when Program_Error => Result := F3A2A00.P_E;       -- Expected result.
         when others        => Result := F3A2A00.O_E;
      end;

      F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #1");

   end SUBTEST1;



   SUBTEST2:
   declare                                                     -- [ Level = 2 ]
      Result : F3A2A00.TC_Result_Kind;
   begin -- SUBTEST2.

      declare                                                  -- [ Level = 3 ]
         -- The instantiation of C3A2A01_1 should NOT result in any
         -- exceptions.

         type AccTag_L3 is access all F3A2A00.Tagged_Type;

         package Pack_OK is new C3A2A01_1 (F3A2A00.Tagged_Type,
                                           AccTag_L3,
                                           F3A2A00.X_L0);
      begin
         -- The accessibility level of the actual object used to instantiate
         -- Pack_OK is 0. The accessibility level of the actual access type
         -- used to instantiate Pack_OK is 3. Therefore, the FObj'Access in
         -- Pack_OK.Handle does not raise an exception when the subprogram is
         -- called. If an exception is (incorrectly) raised, however, it is
         -- handled within the subprogram:

         Pack_OK.Handle (Result);
      end;

      F3A2A00.TC_Display_Results (Result, F3A2A00.OK, "SUBTEST #2");

   exception
      when Program_Error =>
         Report.Failed ("SUBTEST #2: Program_Error incorrectly raised " &
                        "during instantiation of generic");
      when others        =>
         Report.Failed ("SUBTEST #2: Unexpected exception raised " &
                        "during instantiation of generic");
   end SUBTEST2;



   SUBTEST3:
   declare                                                     -- [ Level = 2 ]
      Result : F3A2A00.TC_Result_Kind;
   begin -- SUBTEST3.

      declare                                                  -- [ Level = 3 ]
         -- The instantiation of C3A2A01_1 should NOT result in any
         -- exceptions.

         X_L3: F3A2A00.Tagged_Type;

         package Pack_PE is new C3A2A01_1 (F3A2A00.Tagged_Type,
                                           F3A2A00.AccTag_L0,
                                           X_L3);
      begin
         -- The accessibility level of the actual object used to instantiate
         -- Pack_PE is 3. The accessibility level of the actual access type
         -- used to instantiate Pack_PE is 0. Therefore, the FObj'Access in
         -- Pack_OK.Handle raises Program_Error when the subprogram is
         -- called. The exception is handled within the subprogram:

         Pack_PE.Handle (Result);
      end;

      F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #3");

   exception
      when Program_Error =>
         Report.Failed ("SUBTEST #3: Program_Error incorrectly raised " &
                        "during instantiation of generic");
      when others        =>
         Report.Failed ("SUBTEST #3: Unexpected exception raised " &
                        "during instantiation of generic");
   end SUBTEST3;



   SUBTEST4:
   declare                                                     -- [ Level = 2 ]
      Result1 : F3A2A00.TC_Result_Kind;
      Result2 : F3A2A00.TC_Result_Kind;
   begin -- SUBTEST4.

      declare                                                  -- [ Level = 3 ]
         -- The instantiation of C3A2A01_2 should NOT result in any
         -- exceptions.

         X_L3: aliased F3A2A00.Array_Type;
         type AccArr_L3 is access all F3A2A00.Array_Type;

         procedure Proc is new C3A2A01_2 (F3A2A00.Array_Type, AccArr_L3);
      begin
         -- The accessibility level of Proc.P.all is that of the corresponding
         -- actual during the call (in this case 3). The accessibility level of
         -- the access type used to instantiate Proc is also 3. Therefore, the
         -- P.all'Access in Proc does not raise an exception when the
         -- subprogram is called. If an exception is (incorrectly) raised,
         -- however, it is handled within the subprogram:

         Proc (X_L3'Access, Result1);

         F3A2A00.TC_Display_Results (Result1, F3A2A00.OK,
                                     "SUBTEST #4: same levels");

         declare                                               -- [ Level = 4 ]
            X_L4: aliased F3A2A00.Array_Type;
         begin
            -- Within this block, the accessibility level of the actual
            -- corresponding to Proc.P.all is 4. Therefore, the P.all'Access
            -- in Proc raises Program_Error when the subprogram is called. The
            -- exception is handled within the subprogram:

            Proc (X_L4'Access, Result2);

            F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E,
                                        "SUBTEST #4: object at deeper level");
         end;

      end;

   exception
      when Program_Error =>
         Report.Failed ("SUBTEST #4: Program_Error incorrectly raised " &
                        "during instantiation of generic");
      when others        =>
         Report.Failed ("SUBTEST #4: Unexpected exception raised " &
                        "during instantiation of generic");
   end SUBTEST4;


   Report.Result;

end C3A2A01;