gcc/testsuite/ada/acats/tests/c3/c3a2003.a

   1 -- C3A2003.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. Check for the case where X is
  31 --      an access parameter and the corresponding actual is another access
  32 --      parameter.
  33 --
  34 -- TEST DESCRIPTION:
  35 --      In order to satisfy accessibility requirements, the designated
  36 --      object X must be at the same or a less deep nesting level than the
  37 --      general access type A -- X must "live" as long as A. Nesting
  38 --      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 --      'Access is attempted on a dereference of an access parameter, and
  44 --      assigned to an access object whose type A is declared at some nesting
  45 --      level. The test verifies that Program_Error is raised if the actual
  46 --      corresponding to the access parameter is another access parameter,
  47 --      and the actual corresponding 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 type A -- 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 := X.all'Access;  -- 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, X.all'Access is safe, even though the static nesting
  84 --         level of Actual is deeper than that of A.
  85 --
  86 --
  87 -- CHANGE HISTORY:
  88 --      06 Dec 94   SAIC   ACVC 2.0
  89 --      15 Jul 98   EDS    Avoid optimization.
  90 --      28 Jun 02   RLB    Added pragma Elaborate_All (Report);.
  91 --!
  92
  93 with report; use report; pragma Elaborate_All (report);
  94 package C3A2003_0 is
  95
  96    type Desig is array (1 .. 10) of Integer;
  97
  98    X0 : aliased Desig := (Desig'Range => Ident_Int(3));           -- Level = 0.
  99
 100    type Acc_L0 is access all Desig;                               -- Level = 0.
 101    A0 : Acc_L0;
 102
 103    type Result_Kind is (OK, P_E, O_E);
 104
 105    procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind);
 106    procedure Never_Fails_Nest       (Y: access Desig; S: out Result_Kind);
 107    procedure Never_Fails_Same       (Y: access Desig; S: out Result_Kind);
 108
 109 end C3A2003_0;
 110
 111
 112      --==================================================================--
 113
 114
 115 package body C3A2003_0 is
 116
 117    procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind) is
 118
 119
 120       -- This procedure utilizes 'Access on a dereference of an access
 121       -- parameter, and assigned to an access object whose type A is
 122       -- declared at some nesting level.  Program_Error is raised if
 123       -- the accessibility level of the operand type is deeper than that
 124       -- of the target type.
 125
 126       procedure Nested (X: access Desig; R: out Result_Kind) is
 127          -- Dereference of an access_to_object value is aliased.
 128          Ren : Desig renames X.all;                -- Renaming of a dereference
 129       begin                                        -- of an access parameter.
 130          -- The accessibility level of type A0 is 0.
 131          A0 := Ren'Access;
 132          R  := OK;
 133       exception
 134          when Program_Error =>
 135             R := P_E;
 136          when others        =>
 137             R := O_E;
 138       end Nested;
 139
 140    begin   -- Target_Is_Level_0_Nest
 141       Nested (Y, S);
 142    end Target_Is_Level_0_Nest;
 143
 144    ------------------------------------------------------------------
 145
 146    procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind) is
 147
 148       type Acc_Deeper is access all Desig;
 149       AD : Acc_Deeper;
 150
 151       function Nested (X: access Desig) return Result_Kind is
 152       begin
 153          -- X.all'Access below will always be safe, since the accessibility
 154          -- level (although not necessarily the static nesting depth) of the
 155          -- type of AD will always be deeper than or the same as that of the
 156          -- actual corresponding to Y.
 157          AD := X.all'Access;
 158          if Ident_Int (AD(4)) /= 3 then            --Avoid Optimization of AD
 159            FAILED ("Initial Values not correct.");
 160          end if;
 161          return OK;
 162       exception
 163          when Program_Error =>
 164             return P_E;
 165          when others        =>
 166             return O_E;
 167       end Nested;
 168
 169    begin  -- Never_Fails_Nest
 170       S := Nested (Y);
 171    end Never_Fails_Nest;
 172
 173    ------------------------------------------------------------------
 174
 175    procedure Called_By_Never_Fails_Same
 176      (X: access Desig; R: out Result_Kind) is
 177       type Acc_Local is access all Desig;
 178       AL : Acc_Local;
 179
 180       -- Dereference of an access_to_object value is aliased.
 181       Ren : Desig renames X.all;                   -- Renaming of a dereference
 182    begin                                           -- of an access parameter.
 183       -- Ren'Access below will always be safe, since the accessibility
 184       -- level (although not necessarily the static nesting depth) of
 185       -- type of AL will always be deeper than or the same as that of the
 186       -- actual corresponding to Y.
 187       AL := Ren'Access;
 188       if Ident_Int (AL(4)) /= 3 then       --Avoid Optimization of AL
 189         FAILED ("Initial Values not correct.");
 190       end if;
 191       R  := OK;
 192    exception
 193       when Program_Error =>
 194          R := P_E;
 195       when others        =>
 196          R := O_E;
 197    end Called_By_Never_Fails_Same;
 198
 199    ------------------------------------------------------------------
 200
 201    procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind) is
 202    begin
 203       Called_By_Never_Fails_Same (Y, S);
 204    end Never_Fails_Same;
 205
 206 end C3A2003_0;
 207
 208
 209      --==================================================================--
 210
 211
 212 with C3A2003_0;
 213 use  C3A2003_0;
 214
 215 with Report; use report;
 216
 217 procedure C3A2003 is
 218
 219    type Acc_L1 is access all Desig;                               -- Level = 1.
 220    A1  : Acc_L1;
 221    X1 : aliased Desig := (Desig'Range => Ident_Int(3));
 222    Res : Result_Kind;
 223
 224
 225    procedure Called_By_Target_L1 (X: access Desig; R: out Result_Kind) is
 226    begin
 227       -- The accessibility level of the type of A1 is 1.
 228       A1 := X.all'Access;
 229       if IDENT_INT (A1(4)) /= 3 then       --Avoid optimization of A1
 230         FAILED ("Initial values not correct.");
 231       end if;
 232       R  := OK;
 233    exception
 234       when Program_Error =>
 235          R := P_E;
 236       when others        =>
 237          R := O_E;
 238    end Called_By_Target_L1;
 239
 240    ------------------------------------------------------------------
 241
 242    function Target_Is_Level_1_Same (Y: access Desig) return Result_Kind is
 243       S : Result_Kind;
 244    begin
 245       Called_By_Target_L1 (Y, S);
 246       return S;
 247    end Target_Is_Level_1_Same;
 248
 249    ------------------------------------------------------------------
 250
 251    procedure Display_Results (Result  : in Result_Kind;
 252                               Expected: in Result_Kind;
 253                               Msg     : in String) is
 254    begin
 255       if Result /= Expected then
 256          case Result is
 257             when OK  => Report.Failed ("No exception raised: "         & Msg);
 258             when P_E => Report.Failed ("Program_Error raised: "        & Msg);
 259             when O_E => Report.Failed ("Unexpected exception raised: " & Msg);
 260          end case;
 261       end if;
 262    end Display_Results;
 263
 264 begin -- C3A2003
 265
 266    Report.Test ("C3A2003", "Check that, for X'Access of general access "   &
 267                 "type A, Program_Error is raised if the accessibility "    &
 268                 "level of X is deeper than that of A: X is an access "     &
 269                 "parameter; corresponding actual is another access "       &
 270                 "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 := (Desig'Range => 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    Report.Result;
 328
 329 end C3A2003;