1-- C460002.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 if the target type of a type conversion is a general
28--      access type, Program_Error is raised if the accessibility level
29--      of the operand type is deeper than that of the target type.
30--      Check for the case where the operand is an access parameter,
31--      and the actual corresponding to the access parameter is another
32--      access parameter.
33--
34-- TEST DESCRIPTION:
35--      In order to satisfy accessibility requirements, the operand type
36--      must be at the same or a less deep nesting level than the target
37--      type -- the operand type must "live" as long as the target type.
38--      Nesting levels are the run-time nestings of masters: block statements;
39--      subprogram, task, and entry bodies; and accept statements. Packages
40--      are invisible to accessibility rules.
41--
42--      This test declares subprograms with access parameters, within which
43--      a type conversion is attempted on the access parameter to an access
44--      type A declared at some nesting level. The test verifies that
45--      Program_Error is raised if the actual corresponding to the access
46--      parameter is another access parameter, and the actual corresponding
47--      to this second access parameter is:
48--
49--         (1) an expression of a named access type, and the accessibility
50--             level of the named access type is deeper than that of the
51--             access type A.
52--
53--         (2) a reference to the Access attribute (e.g., X'Access), and
54--             the accessibility level of X is deeper than that of the
55--             access type A.
56--
57--      Note that the static nesting level of the actual corresponding to the
58--      access parameter can be deeper than that of the target type -- it is
59--      the run-time nesting that matters for accessibility rules. Consider
60--      the case where the access type A is declared within the called
61--      subprogram. The accessibility check will never fail, even if the
62--      actual happens to have a deeper static nesting level:
63--
64--         procedure P (X: access T) is
65--            type A is access all T;   -- Static level = 2, e.g.
66--            Acc : A := A(X);          -- Check should never fail.
67--         begin null; end;
68--         . . .
69--         procedure Q (Y: access T) is
70--         begin
71--            P(Y);
72--         end;
73--         . . .
74--         declare
75--            Actual : aliased T;       -- Static level = 3, e.g.
76--         begin
77--            Q (Actual'Access);
78--         end;
79--
80--         For the execution of Q (and hence P), the accessibility level of
81--         type A will always be deeper than that of Actual, so there is no
82--         danger of a dangling reference arising from the assignment to
83--         Acc. Thus, the type conversion is safe, even though the static
84--         nesting level of Actual is deeper than that of A.
85--
86--
87-- CHANGE HISTORY:
88--      06 Dec 94   SAIC    ACVC 2.0
89--      19 Dec 94   SAIC    Changed maintenance documentation.
90--      15 Jul 98   EDS     Avoid Optimization
91--      28 Jun 02   RLB     Added pragma Elaborate_All.
92--!
93
94with Report; use Report; pragma Elaborate_All (Report);
95package C460002_0 is
96
97   type Component is array (1 .. 10) of Natural;
98
99   type Desig is record
100      C: Component;
101   end record;
102
103   X0 : aliased Desig := (C=>(others => Ident_Int(3)));    -- Level = 0.
104
105   type Acc_L0 is access all Desig;                               -- Level = 0.
106   A0 : Acc_L0;
107
108   type Result_Kind is (OK, P_E, O_E);
109
110   procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind);
111   procedure Never_Fails_Nest       (Y: access Desig; S: out Result_Kind);
112   procedure Never_Fails_Same       (Y: access Desig; S: out Result_Kind);
113
114end C460002_0;
115
116
117     --==================================================================--
118
119
120package body C460002_0 is
121
122   procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind) is
123
124      procedure Nested (X: access Desig; R: out Result_Kind) is
125      -- This procedure attempts a type conversion on the access parameter to
126      -- an access type declared at some nesting level.  Program_Error is
127      -- raised if the accessibility level of the operand type is deeper than
128      -- that of the target type.
129
130      begin
131         -- The accessibility level of type Acc_L0 is 0.
132         A0 := Acc_L0(X);
133         R  := OK;
134      exception
135         when Program_Error =>
136            R := P_E;
137         when others        =>
138            R := O_E;
139      end Nested;
140
141   begin
142      Nested (Y, S);
143   end Target_Is_Level_0_Nest;
144
145   -------------------------------------------------------------
146
147   procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind) is
148
149      type Acc_Deeper is access all Desig;
150      AD : Acc_Deeper;
151
152      function Nested (X: access Desig) return Result_Kind is
153      begin
154         -- The type conversion below will always be safe, since the
155         -- accessibility level (although not necessarily the static nesting
156         -- depth) of Acc_Deeper will always be deeper than or the same as that
157         -- of the actual corresponding to Y.
158         AD := Acc_Deeper(X);
159         if Natural(Ident_Int(AD.C(1))) /= 3 then            --Avoid Optimization of AD
160           Report.Failed ("Initial Values not correct.");
161         end if;
162         return OK;
163      exception
164         when Program_Error =>
165            return P_E;
166         when others        =>
167            return O_E;
168      end Nested;
169
170   begin
171      S := Nested (Y);
172   end Never_Fails_Nest;
173
174   -------------------------------------------------------------
175
176   procedure Called_By_Never_Fails_Same
177     (X: access Desig; R: out Result_Kind) is
178      type Acc_Local is access all Desig;
179      AL : Acc_Local;
180   begin
181      -- The type conversion below will always be safe, since the
182      -- accessibility level (although not necessarily the static nesting
183      -- depth) of Acc_Local will always be deeper than or the same as that
184      -- of the actual corresponding to X.
185      AL := Acc_Local(X);
186      if Natural(Ident_Int(AL.C(1))) /= 3 then       --Avoid Optimization of AL
187        Report.Failed ("Initial Values not correct.");
188      end if;
189      R  := OK;
190   exception
191      when Program_Error =>
192         R := P_E;
193      when others        =>
194         R := O_E;
195   end Called_By_Never_Fails_Same;
196
197   -------------------------------------------------------------
198
199   procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind) is
200   begin
201      Called_By_Never_Fails_Same (Y, S);
202   end Never_Fails_Same;
203
204end C460002_0;
205
206
207     --==================================================================--
208
209
210with C460002_0;
211use  C460002_0;
212
213with Report; use Report;
214
215procedure C460002 is
216
217   type Acc_L1 is access all Desig;                               -- Level = 1.
218   A1 : Acc_L1;
219   X1 : aliased Desig := (C=>(others => Ident_Int(3)));
220   Res : Result_Kind;
221
222
223
224   procedure Called_By_Target_L1 (X: access Desig; R: out Result_Kind) is
225   begin
226      -- The accessibility level of type Acc_L1 is 1.
227      A1 := Acc_L1(X);
228      if Natural(Ident_Int(A1.C(1))) /= 3 then       --Avoid Optimization of A1
229        Report.Failed ("Initial Values not correct.");
230      end if;
231      R  := OK;
232   exception
233      when Program_Error =>
234         R := P_E;
235      when others        =>
236         R := O_E;
237   end Called_By_Target_L1;
238
239   -------------------------------------------------------------
240
241   function Target_Is_Level_1_Same (Y: access Desig) return Result_Kind is
242      S : Result_Kind;
243   begin
244      Called_By_Target_L1 (Y, S);
245      return S;
246   end Target_Is_Level_1_Same;
247
248   -------------------------------------------------------------
249
250   procedure Display_Results (Result  : in Result_Kind;
251                              Expected: in Result_Kind;
252                              Msg     : in String) is
253   begin
254      if Result /= Expected then
255         case Result is
256            when OK  => Report.Failed ("No exception raised: "         & Msg);
257            when P_E => Report.Failed ("Program_Error raised: "        & Msg);
258            when O_E => Report.Failed ("Unexpected exception raised: " & Msg);
259         end case;
260      end if;
261   end Display_Results;
262
263begin -- C460002.
264
265   Report.Test ("C460002", "Check that if the target type of a type "      &
266                "conversion is a general access type, Program_Error is "   &
267                "raised if the accessibility level of the operand type "   &
268                "is deeper than that of the target type: operand is an "   &
269                "access parameter; corresponding actual is another "       &
270                "access parameter");
271
272
273   -- Accessibility level of actual is 0 (actual is X'Access):
274
275   Never_Fails_Same (X0'Access, Res);
276   Display_Results (Res, OK, "Never_Fails_Same, level 0 actual");
277
278   Never_Fails_Nest (X0'Access, Res);
279   Display_Results (Res, OK, "Target_L1_Nest, level 0 actual");
280
281   Target_Is_Level_0_Nest (X0'Access, Res);
282   Display_Results (Res, OK, "Target_L0_Nest, level 0 actual");
283
284   Res := Target_Is_Level_1_Same (X0'Access);
285   Display_Results (Res, OK, "Target_L1_Same, level 0 actual");
286
287
288   -- Accessibility level of actual is 1 (actual is X'Access):
289
290   Never_Fails_Same (X1'Access, Res);
291   Display_Results (Res, OK, "Never_Fails_Same, level 1 actual");
292
293   Never_Fails_Nest (X1'Access, Res);
294   Display_Results (Res, OK, "Target_L1_Nest, level 1 actual");
295
296   Target_Is_Level_0_Nest (X1'Access, Res);
297   Display_Results (Res, P_E, "Target_L0_Nest, level 1 actual");
298
299   Res := Target_Is_Level_1_Same (X1'Access);
300   Display_Results (Res, OK, "Target_L1_Same, level 1 actual");
301
302
303   Block_L2:
304   declare
305      X2 : aliased Desig := (C=>(others => Ident_Int(3)));
306      type Acc_L2 is access all Desig;                            -- Level = 2.
307      Expr_L2 : Acc_L2 := X2'Access;
308   begin
309
310      -- Accessibility level of actual is 2 (actual is expression of named
311      -- access type):
312
313      Never_Fails_Same (Expr_L2, Res);
314      Display_Results (Res, OK, "Never_Fails_Same, level 2 actual");
315
316      Never_Fails_Nest (Expr_L2, Res);
317      Display_Results (Res, OK, "Target_L1_Nest, level 2 actual");
318
319      Target_Is_Level_0_Nest (Expr_L2, Res);
320      Display_Results (Res, P_E, "Target_L0_Nest, level 2 actual");
321
322      Res := Target_Is_Level_1_Same (Expr_L2);
323      Display_Results (Res, P_E, "Target_L1_Same, level 2 actual");
324
325   end Block_L2;
326
327
328   Report.Result;
329
330end C460002;
331