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 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.
32 -- Check for cases where the actual corresponding to the access
35 -- (b) An expression of a named access type.
39 -- In order to satisfy accessibility requirements, the operand type
40 -- must be at the same or a less deep nesting level than the target
41 -- type -- the operand type must "live" as long as the target type.
42 -- Nesting levels are the run-time nestings of masters: block statements;
43 -- subprogram, task, and entry bodies; and accept statements. Packages
44 -- are invisible to accessibility rules.
46 -- This test declares subprograms with access parameters, within which
47 -- a type conversion is attempted on the access parameter to an access
48 -- type A declared at some nesting level. The test verifies that
49 -- Program_Error is raised if the actual corresponding to the access
52 -- (1) an allocator, and the accessibility level of the execution
53 -- of the called subprogram is deeper than that of the access
56 -- (2) an expression of a named access type, and the accessibility
57 -- level of the named access type is deeper than that of the
60 -- (3) a reference to the Access attribute (e.g., X'Access), and
61 -- the accessibility level of X is deeper than that of the
64 -- Note that the static nesting level of the actual corresponding to the
65 -- access parameter can be deeper than that of the target type -- it is
66 -- the run-time nesting that matters for accessibility rules. Consider
67 -- the case where the access type A is declared within the called
68 -- subprogram. The accessibility check will never fail, even if the
69 -- actual happens to have a deeper static nesting level:
71 -- procedure P (X: access T) is
72 -- type A is access all T; -- Static level = 2, e.g.
73 -- Acc : A := A(X); -- Check should never fail.
77 -- Actual : aliased T; -- Static level = 3, e.g.
82 -- For the execution of P, the accessibility level of type A will
83 -- always be deeper than that of Actual, so there is no danger of a
84 -- dangling reference arising from the assignment to Acc. Thus, the
85 -- type conversion is safe, even though the static nesting level of
86 -- Actual is deeper than that of A.
90 -- 06 Dec 94 SAIC ACVC 2.0
96 type Desig
is array (1 .. 10) of Integer;
98 X0
: aliased Desig
; -- Level = 0.
100 type Acc_L0
is access all Desig
; -- Level = 0.
103 type Result_Kind
is (OK
, P_E
, O_E
);
105 procedure Target_Is_Level_0
(X
: access Desig
; R
: out Result_Kind
);
106 procedure Never_Fails
(X
: access Desig
; R
: out Result_Kind
);
111 --==================================================================--
114 package body C460001_0
is
116 procedure Target_Is_Level_0
(X
: access Desig
;
117 R
: out Result_Kind
) is
119 -- The accessibility level of type Acc_L0 is 0.
123 when Program_Error
=>
127 end Target_Is_Level_0
;
129 -----------------------------------------------
130 procedure Never_Fails
(X
: access Desig
;
131 R
: out Result_Kind
) is
132 type Acc_Local
is access all Desig
;
135 -- The type conversion below will always be safe, since the
136 -- accessibility level (although not necessarily the static nesting
137 -- depth) of Acc_Local will always be deeper than or the same as that
138 -- of the actual corresponding to X.
142 when Program_Error
=>
151 --==================================================================--
159 X1
: aliased C460001_0
.Desig
; -- Level = 1.
161 type Acc_L1
is access all C460001_0
.Desig
; -- Level = 1.
164 Expr_L0
: C460001_0
.Acc_L0
:= C460001_0
.X0
'Access;
165 Expr_L1
: Acc_L1
:= X1
'Access;
167 Res
: C460001_0
.Result_Kind
;
169 use type C460001_0
.Result_Kind
;
171 -----------------------------------------------
172 procedure Target_Is_Level_1
(X
: access C460001_0
.Desig
;
173 R
: out C460001_0
.Result_Kind
) is
175 -- The accessibility level of type Acc_L1 is 1.
179 when Program_Error
=>
183 end Target_Is_Level_1
;
185 -----------------------------------------------
186 procedure Display_Results
(Result
: in C460001_0
.Result_Kind
;
187 Expected
: in C460001_0
.Result_Kind
;
188 Message
: in String) is
190 if Result
/= Expected
then
192 when C460001_0
.OK
=> Report
.Failed
("No exception raised: " &
194 when C460001_0
.P_E
=> Report
.Failed
("Program_Error raised: " &
196 when C460001_0
.O_E
=> Report
.Failed
("Unexpected exception " &
197 "raised: " & Message
);
204 Report
.Test
("C460001", "Check that if the target type of a type " &
205 "conversion is a general access type, Program_Error is " &
206 "raised if the accessibility level of the operand type " &
207 "is deeper than that of the target type: operand is an " &
208 "access parameter; corresponding actual is an allocator, " &
209 "expression of a named access type, Obj'Access");
212 -- Actual is X'Access:
214 C460001_0
.Never_Fails
(X1
'Access, Res
);
215 Display_Results
(Res
, C460001_0
.OK
, "X1'Access, local access type");
217 C460001_0
.Target_Is_Level_0
(X1
'Access, Res
);
218 Display_Results
(Res
, C460001_0
.P_E
, "X1'Access, level 0 access type");
220 Target_Is_Level_1
(C460001_0
.X0
'Access, Res
);
221 Display_Results
(Res
, C460001_0
.OK
, "X0'Access, level 1 access type");
223 Target_Is_Level_1
(X1
'Access, Res
);
224 Display_Results
(Res
, C460001_0
.OK
, "X1'Access, level 1 access type");
226 C460001_0
.Target_Is_Level_0
(C460001_0
.X0
'Access, Res
);
227 Display_Results
(Res
, C460001_0
.OK
, "X0'Access, level 0 access type");
230 -- Actual is expression of a named access type:
232 C460001_0
.Never_Fails
(Expr_L0
, Res
);
233 Display_Results
(Res
, C460001_0
.OK
, "Expr_L0, local access type");
235 C460001_0
.Target_Is_Level_0
(Expr_L0
, Res
);
236 Display_Results
(Res
, C460001_0
.OK
, "Expr_L0, level 0 access type");
238 C460001_0
.Target_Is_Level_0
(Expr_L1
, Res
);
239 Display_Results
(Res
, C460001_0
.P_E
, "Expr_L1, level 0 access type");
241 Target_Is_Level_1
(Expr_L1
, Res
);
242 Display_Results
(Res
, C460001_0
.OK
, "Expr_L1, level 1 access type");
244 Target_Is_Level_1
(Expr_L0
, Res
);
245 Display_Results
(Res
, C460001_0
.OK
, "Expr_L0, level 1 access type");
247 -- Actual is allocator (level of execution = 2):
249 C460001_0
.Never_Fails
(new C460001_0
.Desig
, Res
);
250 Display_Results
(Res
, C460001_0
.OK
, "Allocator level 2, " &
251 "local access type");
253 C460001_0
.Target_Is_Level_0
(new C460001_0
.Desig
, Res
);
254 Display_Results
(Res
, C460001_0
.P_E
, "Allocator level 2, " &
255 "level 0 access type");
257 Target_Is_Level_1
(new C460001_0
.Desig
, Res
);
258 Display_Results
(Res
, C460001_0
.P_E
, "Allocator level 2, " &
259 "level 1 access type");
264 X2
: aliased C460001_0
.Desig
; -- Level = 2.
265 type Acc_L2
is access all C460001_0
.Desig
; -- Level = 2.
266 Expr_L2
: Acc_L2
:= X1
'Access;
269 -- Actual is X'Access:
271 C460001_0
.Never_Fails
(X2
'Access, Res
);
272 Display_Results
(Res
, C460001_0
.OK
, "X2'Access, local access type");
274 Target_Is_Level_1
(X2
'Access, Res
);
275 Display_Results
(Res
, C460001_0
.P_E
, "X2'Access, level 1 access type");
277 -- Actual is expression of a named access type:
279 C460001_0
.Never_Fails
(Expr_L2
, Res
);
280 Display_Results
(Res
, C460001_0
.OK
, "Expr_L2, local access type");
282 C460001_0
.Target_Is_Level_0
(Expr_L2
, Res
);
283 Display_Results
(Res
, C460001_0
.P_E
, "Expr_L2, level 0 access type");
286 -- Actual is allocator (level of execution = 3):
288 C460001_0
.Never_Fails
(new C460001_0
.Desig
, Res
);
289 Display_Results
(Res
, C460001_0
.OK
, "Allocator level 3, " &
290 "local access type");
292 Target_Is_Level_1
(new C460001_0
.Desig
, Res
);
293 Display_Results
(Res
, C460001_0
.P_E
, "Allocator level 3, " &
294 "level 1 access type");