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

   1 -- C3A2A01.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 cases where X'Access occurs in an instance body, and A
  30 --      is passed as an actual during instantiation.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      In order to satisfy accessibility requirements, the designated
  34 --      object X must be at the same or a less deep nesting level than the
  35 --      general access type A -- X must "live" as long as A. Nesting
  36 --      levels are the run-time nestings of masters: block statements;
  37 --      subprogram, task, and entry bodies; and accept statements. Packages
  38 --      are invisible to accessibility rules.
  39 --
  40 --      This test declares three generic units, each of which has a formal
  41 --      general access type:
  42 --
  43 --         (1) A generic package, in which X is declared in the specification,
  44 --             and X'Access occurs within the declarative part of the body.
  45 --
  46 --         (2) A generic package, in which X is a formal in out object of a
  47 --             tagged formal derived type, and X'Access occurs in the sequence
  48 --             of statements of a nested subprogram.
  49 --
  50 --         (3) A generic procedure, in which X is a dereference of an access
  51 --             parameter, and X'Access occurs in the sequence of statements.
  52 --
  53 --      The test verifies the following:
  54 --
  55 --         For (1), Program_Error is raised upon instantiation if the generic
  56 --         package is instantiated at a deeper level than that of the general
  57 --         access type passed as an actual. The exception is propagated to the
  58 --         innermost enclosing master.
  59 --
  60 --         For (2), Program_Error is raised when the nested subprogram is
  61 --         called if the object passed as an actual during instantiation of
  62 --         the generic package has an accessibility level deeper than that of
  63 --         the general access type passed as an actual. The exception is
  64 --         handled within the nested subprogram. Also, check that
  65 --         Program_Error is not raised if the level of the actual access type
  66 --         is deeper than that of the actual object.
  67 --
  68 --         For (3), Program_Error is raised when the instance subprogram is
  69 --         called if the object pointed to by the actual corresponding to
  70 --         the access parameter has an accessibility level deeper than that of
  71 --         the general access type passed as an actual during instantiation.
  72 --         The exception is handled within the instance subprogram. Also,
  73 --         check that Program_Error is not raised if the level of the actual
  74 --         access type is deeper than that of the actual corresponding to the
  75 --         access parameter.
  76 --
  77 -- TEST FILES:
  78 --      The following files comprise this test:
  79 --
  80 --         F3A2A00.A
  81 --      -> C3A2A01.A
  82 --
  83 --
  84 -- CHANGE HISTORY:
  85 --      12 May 95   SAIC    Initial prerelease version.
  86 --      10 Jul 95   SAIC    Modified code to avoid dead variable optimization.
  87 --
  88 --!
  89
  90 with F3A2A00;
  91 generic
  92    type FD  is new F3A2A00.Array_Type;
  93    type FAF is access all FD;
  94 package C3A2A01_0 is
  95    X : aliased FD;
  96
  97    procedure Dummy;  -- Needed to allow package body.
  98 end C3A2A01_0;
  99
 100
 101      --==================================================================--
 102
 103
 104 with Report;
 105 package body C3A2A01_0 is
 106    Ptr   : FAF     := X'Access;
 107    Index : Integer := F3A2A00.Array_Type'First;
 108
 109    procedure Dummy is
 110    begin
 111       null;
 112    end Dummy;
 113 begin
 114    -- Avoid optimization (dead variable removal of Ptr):
 115
 116    if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then   -- Always false.
 117       Report.Failed ("Unexpected error in C3A2A01_0 instance");
 118    end if;
 119 end C3A2A01_0;
 120
 121
 122      --==================================================================--
 123
 124
 125 with F3A2A00;
 126 generic
 127    type FD  is new F3A2A00.Tagged_Type with private;
 128    type FAF is access all FD;
 129    FObj : in out FD;
 130 package C3A2A01_1 is
 131    procedure Handle (R: out F3A2A00.TC_Result_Kind);
 132 end C3A2A01_1;
 133
 134
 135      --==================================================================--
 136
 137
 138 with Report;
 139 package body C3A2A01_1 is
 140
 141    procedure Handle (R: out F3A2A00.TC_Result_Kind) is
 142       Ptr : FAF;
 143    begin
 144       Ptr := FObj'Access;
 145       R   := F3A2A00.OK;
 146
 147       -- Avoid optimization (dead variable removal of Ptr):
 148
 149       if not Report.Equal (Ptr.C, Ptr.C) then              -- Always false.
 150          Report.Failed ("Unexpected error in Handle");
 151       end if;
 152    exception
 153       when Program_Error => R := F3A2A00.P_E;
 154       when others        => R := F3A2A00.O_E;
 155    end Handle;
 156
 157 end C3A2A01_1;
 158
 159
 160      --==================================================================--
 161
 162
 163 with F3A2A00;
 164 generic
 165    type FD  is new F3A2A00.Array_Type;
 166    type FAF is access all FD;
 167 procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind);
 168
 169
 170      --==================================================================--
 171
 172
 173 with Report;
 174 procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind) is
 175    Ptr   : FAF;
 176    Index : Integer := F3A2A00.Array_Type'First;
 177 begin
 178    Ptr := P.all'Access;
 179    R   := F3A2A00.OK;
 180
 181    -- Avoid optimization (dead variable removal of Ptr):
 182
 183    if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then   -- Always false.
 184       Report.Failed ("Unexpected error in C3A2A01_2 instance");
 185    end if;
 186 exception
 187    when Program_Error => R := F3A2A00.P_E;
 188    when others        => R := F3A2A00.O_E;
 189 end C3A2A01_2;
 190
 191
 192      --==================================================================--
 193
 194
 195 with F3A2A00;
 196 with C3A2A01_0;
 197 with C3A2A01_1;
 198 with C3A2A01_2;
 199
 200 with Report;
 201 procedure C3A2A01 is
 202 begin -- C3A2A01.                                              -- [ Level = 1 ]
 203
 204    Report.Test ("C3A2A01", "Run-time accessibility checks: instance " &
 205                 "bodies. Type of X'Access is passed as actual to instance");
 206
 207
 208    SUBTEST1:
 209    declare                                                     -- [ Level = 2 ]
 210       Result : F3A2A00.TC_Result_Kind;
 211    begin -- SUBTEST1.
 212
 213       declare                                                  -- [ Level = 3 ]
 214          type AccArr_L3 is access all F3A2A00.Array_Type;
 215       begin
 216          declare                                               -- [ Level = 4 ]
 217             -- The accessibility level of Pack.X is that of the instantiation
 218             -- (4). The accessibility level of the actual access type used to
 219             -- instantiate Pack is 3. Therefore, the X'Access in Pack
 220             -- propagates Program_Error when the instance body is elaborated:
 221
 222             package Pack is new C3A2A01_0 (F3A2A00.Array_Type, AccArr_L3);
 223          begin
 224             Result := F3A2A00.OK;
 225          end;
 226       exception
 227          when Program_Error => Result := F3A2A00.P_E;       -- Expected result.
 228          when others        => Result := F3A2A00.O_E;
 229       end;
 230
 231       F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #1");
 232
 233    end SUBTEST1;
 234
 235
 236
 237    SUBTEST2:
 238    declare                                                     -- [ Level = 2 ]
 239       Result : F3A2A00.TC_Result_Kind;
 240    begin -- SUBTEST2.
 241
 242       declare                                                  -- [ Level = 3 ]
 243          -- The instantiation of C3A2A01_1 should NOT result in any
 244          -- exceptions.
 245
 246          type AccTag_L3 is access all F3A2A00.Tagged_Type;
 247
 248          package Pack_OK is new C3A2A01_1 (F3A2A00.Tagged_Type,
 249                                            AccTag_L3,
 250                                            F3A2A00.X_L0);
 251       begin
 252          -- The accessibility level of the actual object used to instantiate
 253          -- Pack_OK is 0. The accessibility level of the actual access type
 254          -- used to instantiate Pack_OK is 3. Therefore, the FObj'Access in
 255          -- Pack_OK.Handle does not raise an exception when the subprogram is
 256          -- called. If an exception is (incorrectly) raised, however, it is
 257          -- handled within the subprogram:
 258
 259          Pack_OK.Handle (Result);
 260       end;
 261
 262       F3A2A00.TC_Display_Results (Result, F3A2A00.OK, "SUBTEST #2");
 263
 264    exception
 265       when Program_Error =>
 266          Report.Failed ("SUBTEST #2: Program_Error incorrectly raised " &
 267                         "during instantiation of generic");
 268       when others        =>
 269          Report.Failed ("SUBTEST #2: Unexpected exception raised " &
 270                         "during instantiation of generic");
 271    end SUBTEST2;
 272
 273
 274
 275    SUBTEST3:
 276    declare                                                     -- [ Level = 2 ]
 277       Result : F3A2A00.TC_Result_Kind;
 278    begin -- SUBTEST3.
 279
 280       declare                                                  -- [ Level = 3 ]
 281          -- The instantiation of C3A2A01_1 should NOT result in any
 282          -- exceptions.
 283
 284          X_L3: F3A2A00.Tagged_Type;
 285
 286          package Pack_PE is new C3A2A01_1 (F3A2A00.Tagged_Type,
 287                                            F3A2A00.AccTag_L0,
 288                                            X_L3);
 289       begin
 290          -- The accessibility level of the actual object used to instantiate
 291          -- Pack_PE is 3. The accessibility level of the actual access type
 292          -- used to instantiate Pack_PE is 0. Therefore, the FObj'Access in
 293          -- Pack_OK.Handle raises Program_Error when the subprogram is
 294          -- called. The exception is handled within the subprogram:
 295
 296          Pack_PE.Handle (Result);
 297       end;
 298
 299       F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #3");
 300
 301    exception
 302       when Program_Error =>
 303          Report.Failed ("SUBTEST #3: Program_Error incorrectly raised " &
 304                         "during instantiation of generic");
 305       when others        =>
 306          Report.Failed ("SUBTEST #3: Unexpected exception raised " &
 307                         "during instantiation of generic");
 308    end SUBTEST3;
 309
 310
 311
 312    SUBTEST4:
 313    declare                                                     -- [ Level = 2 ]
 314       Result1 : F3A2A00.TC_Result_Kind;
 315       Result2 : F3A2A00.TC_Result_Kind;
 316    begin -- SUBTEST4.
 317
 318       declare                                                  -- [ Level = 3 ]
 319          -- The instantiation of C3A2A01_2 should NOT result in any
 320          -- exceptions.
 321
 322          X_L3: aliased F3A2A00.Array_Type;
 323          type AccArr_L3 is access all F3A2A00.Array_Type;
 324
 325          procedure Proc is new C3A2A01_2 (F3A2A00.Array_Type, AccArr_L3);
 326       begin
 327          -- The accessibility level of Proc.P.all is that of the corresponding
 328          -- actual during the call (in this case 3). The accessibility level of
 329          -- the access type used to instantiate Proc is also 3. Therefore, the
 330          -- P.all'Access in Proc does not raise an exception when the
 331          -- subprogram is called. If an exception is (incorrectly) raised,
 332          -- however, it is handled within the subprogram:
 333
 334          Proc (X_L3'Access, Result1);
 335
 336          F3A2A00.TC_Display_Results (Result1, F3A2A00.OK,
 337                                      "SUBTEST #4: same levels");
 338
 339          declare                                               -- [ Level = 4 ]
 340             X_L4: aliased F3A2A00.Array_Type;
 341          begin
 342             -- Within this block, the accessibility level of the actual
 343             -- corresponding to Proc.P.all is 4. Therefore, the P.all'Access
 344             -- in Proc raises Program_Error when the subprogram is called. The
 345             -- exception is handled within the subprogram:
 346
 347             Proc (X_L4'Access, Result2);
 348
 349             F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E,
 350                                         "SUBTEST #4: object at deeper level");
 351          end;
 352
 353       end;
 354
 355    exception
 356       when Program_Error =>
 357          Report.Failed ("SUBTEST #4: Program_Error incorrectly raised " &
 358                         "during instantiation of generic");
 359       when others        =>
 360          Report.Failed ("SUBTEST #4: Unexpected exception raised " &
 361                         "during instantiation of generic");
 362    end SUBTEST4;
 363
 364
 365    Report.Result;
 366
 367 end C3A2A01;