1-- C3A2002.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 the case where X denotes a view that is a dereference of an 30-- access parameter, or a rename thereof. 31-- 32-- Check for cases where the actual corresponding to X is: 33-- (a) An allocator. 34-- (b) An expression of a named access type. 35-- (c) Obj'Access. 36-- 37-- TEST DESCRIPTION: 38-- In order to satisfy accessibility requirements, the designated 39-- object X must be at the same or a less deep nesting level than the 40-- general access type A -- X must "live" as long as A. Nesting 41-- levels are the run-time nestings of masters: block statements; 42-- subprogram, task, and entry bodies; and accept statements. Packages 43-- are invisible to accessibility rules. 44-- 45-- This test declares subprograms with access parameters, within which 46-- 'Access is attempted on a dereference of the access parameter, and 47-- assigned to an access object whose type A is declared at some nesting 48-- level. The test verifies that Program_Error is raised if the actual 49-- corresponding to the access parameter is: 50-- 51-- (1) an allocator, and the accessibility level of the execution 52-- of the called subprogram is deeper than that of the access 53-- type A. 54-- 55-- (2) an expression of a named access type, and the accessibility 56-- level of the named access type is deeper than that of the 57-- access type A. 58-- 59-- (3) a reference to the Access attribute (e.g., X'Access), and 60-- the accessibility level of X is deeper than that of the 61-- access type A. 62-- 63-- Note that the static nesting level of the actual corresponding to the 64-- access parameter can be deeper than that of the type A -- it is 65-- the run-time nesting that matters for accessibility rules. Consider 66-- the case where the access type A is declared within the called 67-- subprogram. The accessibility check will never fail, even if the 68-- actual happens to have a deeper static nesting level: 69-- 70-- procedure P (X: access T) is 71-- type A is access all T; -- Static level = 2, e.g. 72-- Acc : A := X.all'Access; -- Check should never fail. 73-- begin null; end; 74-- . . . 75-- declare 76-- Actual : aliased T; -- Static level = 3, e.g. 77-- begin 78-- P (Actual'Access); 79-- end; 80-- 81-- For the execution of P, the accessibility level of type A will 82-- always be deeper than that of Actual, so there is no danger of a 83-- dangling reference arising from the assignment to Acc. Thus, 84-- X.all'Access is safe, even though the static nesting level of 85-- Actual is deeper than that of A. 86-- 87-- 88-- CHANGE HISTORY: 89-- 06 Dec 94 SAIC ACVC 2.0 90-- 91--! 92 93package C3A2002_0 is 94 95 type Desig is array (1 .. 10) of Integer; 96 97 X0 : aliased Desig; -- Level = 0. 98 99 type Acc_L0 is access all Desig; -- Level = 0. 100 A0 : Acc_L0; 101 102 type Result_Kind is (OK, P_E, O_E); 103 104 procedure A_Is_Level_0 (X: access Desig; R : out Result_Kind); 105 procedure Never_Fails (X: access Desig; R : out Result_Kind); 106 107end C3A2002_0; 108 109 110 --==================================================================-- 111 112package body C3A2002_0 is 113 114 procedure A_Is_Level_0 (X : access Desig; 115 R : out Result_Kind) is 116 begin 117 -- The accessibility level of the type of A0 is 0. 118 A0 := X.all'Access; 119 R := OK; 120 exception 121 when Program_Error => 122 R := P_E; 123 when others => 124 R := O_E; 125 end A_Is_Level_0; 126 127 ----------------------------------------------- 128 procedure Never_Fails (X: access Desig; 129 R : out Result_Kind) is 130 type Acc_Local is access all Desig; 131 AL : Acc_Local; 132 begin 133 -- X.all'Access below will always be safe, since the accessibility 134 -- level (although not necessarily the static nesting depth) of the 135 -- type of AL will always be deeper than or the same as that of the 136 -- actual corresponding to Y. 137 AL := X.all'Access; 138 R := OK; 139 exception 140 when Program_Error => 141 R := P_E; 142 when others => 143 R := O_E; 144 end Never_Fails; 145 146end C3A2002_0; 147 148 149 --==================================================================-- 150 151 152with C3A2002_0; 153with Report; 154 155procedure C3A2002 is 156 157 X1 : aliased C3A2002_0.Desig; -- Level = 1. 158 159 type Acc_L1 is access all C3A2002_0.Desig; -- Level = 1. 160 A1 : Acc_L1; 161 162 Expr_L0 : C3A2002_0.Acc_L0 := C3A2002_0.X0'Access; 163 Expr_L1 : Acc_L1 := X1'Access; 164 165 Res : C3A2002_0.Result_Kind; 166 167 use type C3A2002_0.Result_Kind; 168 169 ----------------------------------------------- 170 procedure A_Is_Level_1 (X : access C3A2002_0.Desig; 171 R : out C3A2002_0.Result_Kind) is 172 -- Dereference of an access_to_object value is aliased. 173 Ren : C3A2002_0.Desig renames X.all; -- Renaming of a dereference 174 begin -- of an access parameter. 175 -- The accessibility level of the type of A1 is 1. 176 A1 := Ren'Access; 177 R := C3A2002_0.OK; 178 exception 179 when Program_Error => 180 R := C3A2002_0.P_E; 181 when others => 182 R := C3A2002_0.O_E; 183 end A_Is_Level_1; 184 185 ----------------------------------------------- 186 procedure Display_Results (Result : in C3A2002_0.Result_Kind; 187 Expected: in C3A2002_0.Result_Kind; 188 Message : in String) is 189 begin 190 if Result /= Expected then 191 case Result is 192 when C3A2002_0.OK => Report.Failed ("No exception raised: " & 193 Message); 194 when C3A2002_0.P_E => Report.Failed ("Program_Error raised: " & 195 Message); 196 when C3A2002_0.O_E => Report.Failed ("Unexpected exception " & 197 "raised: " & Message); 198 end case; 199 end if; 200 end Display_Results; 201 202begin -- C3A2002 203 204 Report.Test ("C3A2002", "Check that, for X'Access of general access " & 205 "type A, Program_Error is raised if the accessibility " & 206 "level of X is deeper than that of A: X is an access " & 207 "parameter; corresponding actual is an allocator, " & 208 "expression of a named access type, Obj'Access, or a " & 209 "rename thereof"); 210 211 212 -- Actual is X'Access: 213 214 C3A2002_0.Never_Fails (C3A2002_0.X0'Access, Res); 215 Display_Results (Res, C3A2002_0.OK, "X0'Access, local access type"); 216 217 C3A2002_0.A_Is_Level_0 (C3A2002_0.X0'Access, Res); 218 Display_Results (Res, C3A2002_0.OK, "X0'Access, level 0 access type"); 219 220 C3A2002_0.A_Is_Level_0 (X1'Access, Res); 221 Display_Results (Res, C3A2002_0.P_E, "X1'Access, level 0 access type"); 222 223 A_Is_Level_1 (X1'Access, Res); 224 Display_Results (Res, C3A2002_0.OK, "X1'Access, level 1 access type"); 225 226 227 -- Actual is expression of a named access type: 228 229 C3A2002_0.Never_Fails (Expr_L1, Res); 230 Display_Results (Res, C3A2002_0.OK, "Expr_L1, local access type"); 231 232 C3A2002_0.A_Is_Level_0 (Expr_L1, Res); 233 Display_Results (Res, C3A2002_0.P_E, "Expr_L1, level 0 access type"); 234 235 A_Is_Level_1 (Expr_L0, Res); 236 Display_Results (Res, C3A2002_0.OK, "Expr_L0, level 1 access type"); 237 238 A_Is_Level_1 (Expr_L1, Res); 239 Display_Results (Res, C3A2002_0.OK, "Expr_L1, level 1 access type"); 240 241 -- Actual is allocator (level of execution = 2): 242 243 C3A2002_0.Never_Fails (new C3A2002_0.Desig, Res); 244 Display_Results (Res, C3A2002_0.OK, "Allocator level 2, " & 245 "local access type"); 246 247 -- Since actual is an allocator, its accessibility level is that of 248 -- the execution of the called subprogram, i.e., level 2. 249 250 C3A2002_0.A_Is_Level_0 (new C3A2002_0.Desig, Res); 251 Display_Results (Res, C3A2002_0.P_E, "Allocator level 2, " & 252 "level 0 access type"); 253 254 A_Is_Level_1 (new C3A2002_0.Desig, Res); 255 Display_Results (Res, C3A2002_0.P_E, "Allocator level 2, " & 256 "level 1 access type"); 257 258 259 Block_L2: 260 declare 261 X2 : aliased C3A2002_0.Desig; -- Level = 2. 262 type Acc_L2 is access all C3A2002_0.Desig; -- Level = 2. 263 Expr_L2 : Acc_L2 := X1'Access; 264 begin 265 266 -- Actual is X'Access: 267 268 C3A2002_0.Never_Fails (X2'Access, Res); 269 Display_Results (Res, C3A2002_0.OK, "X2'Access, local access type"); 270 271 C3A2002_0.A_Is_Level_0 (X2'Access, Res); 272 Display_Results (Res, C3A2002_0.P_E, "X2'Access, level 0 access type"); 273 274 275 -- Actual is expression of a named access type: 276 277 A_Is_Level_1 (Expr_L2, Res); 278 Display_Results (Res, C3A2002_0.P_E, "Expr_L2, level 1 access type"); 279 280 281 -- Actual is allocator (level of execution = 3): 282 283 C3A2002_0.Never_Fails (new C3A2002_0.Desig, Res); 284 Display_Results (Res, C3A2002_0.OK, "Allocator level 3, " & 285 "local access type"); 286 287 A_Is_Level_1 (new C3A2002_0.Desig, Res); 288 Display_Results (Res, C3A2002_0.P_E, "Allocator level 3, " & 289 "level 1 access type"); 290 291 end Block_L2; 292 293 Report.Result; 294 295end C3A2002; 296