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

   1 -- C3A0014.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 view defined by an object declaration is aliased,
  28 --      and the type of the object has discriminants, then the object is
  29 --      constrained by its initial value even if its nominal subtype is
  30 --      unconstrained.
  31 --
  32 --      Check that the attribute A'Constrained returns True if A is a formal
  33 --      out or in out parameter, or dereference thereof, and A denotes an
  34 --      aliased view of an object.
  35 --
  36 -- TEST DESCRIPTION:
  37 --      These rules apply to objects of a record type with defaulted
  38 --      discriminants, which may be unconstrained variables. If such a
  39 --      variable is declared to be aliased, then it is constrained by its
  40 --      initial value, and the value of the discriminant cannot be changed
  41 --      for the life of the variable.
  42 --
  43 --      The rules do not apply to aliased component types because if such
  44 --      types are discriminated they must be constrained.
  45 --
  46 --      A'Constrained returns True if A denotes a constant, value, or
  47 --      constrained variable. Since aliased objects are constrained, it must
  48 --      return True if the actual parameter corresponding to a formal
  49 --      parameter A is an aliased object. The objective only mentions formal
  50 --      parameters of mode out and in out, since parameters of mode in are
  51 --      by definition constant, and would result in True anyway.
  52 --
  53 --      This test declares aliased objects of a nominally unconstrained
  54 --      record subtype, both with and without initialization expressions.
  55 --      It also declares access values which point to such objects. It then
  56 --      checks that Constraint_Error is raised if an attempt is made to
  57 --      change the discriminant value of an aliased object, either directly
  58 --      or via a dereference of an access value. For aliased objects, this
  59 --      check is also performed for subprogram parameters of mode out.
  60 --
  61 --      The test also passes aliased objects and access values which point
  62 --      to such objects as actuals to subprograms and verifies, for parameter
  63 --      modes out and in out, that P'Constrained returns true if P is the
  64 --      corresponding formal parameter or a dereference thereof.
  65 --
  66 --      Additionally, the test declares a generic package which declares a
  67 --      an aliased object of a formal derived unconstrained type, which is
  68 --      is initialized with the value of a formal object of that type.
  69 --      procedure declared within the generic assigns a value to the object
  70 --      which has the same discriminant value as the formal derived type's
  71 --      ancestor type. The generic is instantiated with various actuals
  72 --      for the formal object, and the procedure is called. The test verifies
  73 --      that Constraint_Error is raised if the discriminant values of the
  74 --      actual corresponding to the formal object and the value assigned
  75 --      by the procedure are not equal.
  76 --
  77 --
  78 -- CHANGE HISTORY:
  79 --      06 Dec 94   SAIC    ACVC 2.0
  80 --      16 Nov 95   SAIC    ACVC 2.0.1 fixes: Corrected numerous errors.
  81 --
  82 --!
  83
  84 package C3A0014_0 is
  85
  86    subtype Reasonable is Integer range 1..10;
  87                                           -- Unconstrained (sub)type.
  88    type UC (D: Reasonable := 2) is record -- Discriminant default.
  89       S: String (1 .. D) := "Hi";         -- Default value.
  90    end record;
  91
  92    type AUC is access all UC;
  93
  94    -- Nominal subtype is unconstrained for the following:
  95
  96    Obj0 :         UC;                  -- An unconstrained object.
  97
  98    Obj1 :         UC := (5, "Hello");  -- Non-aliased with initialization,
  99                                        -- an unconstrained object.
 100
 101    Obj2 : aliased UC := (5, "Hello");  -- Aliased with initialization,
 102                                        -- a constrained object.
 103
 104    Obj3 :         UC renames Obj2;     -- Aliased (renaming of aliased view),
 105                                        -- a constrained object.
 106    Obj4 : aliased UC;                  -- Aliased without initialization, Obj4
 107                                        -- constrained here to initial value
 108                                        -- taken from default for type.
 109
 110    Ptr1 : AUC := new UC'(Obj1);
 111    Ptr2 : AUC := new UC;
 112    Ptr3 : AUC := Obj3'Access;
 113    Ptr4 : AUC := Obj4'Access;
 114
 115
 116    procedure NP_Proc (A:    out UC);
 117    procedure NP_Cons (A: in out UC;  B: out Boolean);
 118    procedure P_Cons  (A:    out AUC; B: out Boolean);
 119
 120
 121    generic
 122       type FT is new UC;
 123       FObj : in out FT;
 124    package Gen is
 125       F  : aliased FT := FObj;     -- Constrained if FT has discriminants.
 126       procedure Proc;
 127    end Gen;
 128
 129
 130    procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String );
 131
 132
 133 end C3A0014_0;
 134
 135
 136   --=======================================================================--
 137
 138 with Report;
 139
 140 package body C3A0014_0 is
 141
 142    procedure NP_Proc (A: out UC) is
 143    begin
 144       A := (3, "Bye");
 145    end NP_Proc;
 146
 147    procedure NP_Cons (A: in out UC; B: out Boolean) is
 148    begin
 149       B := A'Constrained;
 150    end NP_Cons;
 151
 152    procedure P_Cons (A: out AUC; B: out Boolean) is
 153    begin
 154       B := A.all'Constrained;
 155    end P_Cons;
 156
 157
 158    package body Gen is
 159
 160       procedure Proc is
 161       begin
 162          F := (2, "Fi");
 163       end Proc;
 164
 165    end Gen;
 166
 167
 168    procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ) is
 169       Default : UC := (1, "!"); -- Unique value.
 170    begin
 171       if P = Default then       -- Both If branches can't do the same thing.
 172          Report.Failed  (Msg & ": Constraint_Error not raised");
 173       else                      -- Subtests should always select this path.
 174          Report.Failed ("Constraint_Error not raised " & Msg);
 175       end if;
 176    end Avoid_Optimization_and_Fail;
 177
 178
 179 end C3A0014_0;
 180
 181
 182   --=======================================================================--
 183
 184
 185 with C3A0014_0;  use C3A0014_0;
 186 with Report;
 187
 188 procedure C3A0014 is
 189 begin
 190
 191    Report.Test("C3A0014", "Check that if the view defined by an object "   &
 192                           "declaration is aliased, and the type of the "   &
 193                           "object has discriminants, then the object is "  &
 194                           "constrained by its initial value even if its "  &
 195                           "nominal subtype is unconstrained.  Check that " &
 196                           "the attribute A'Constrained returns True if A " &
 197                           "is a formal out or in out parameter, or "       &
 198                           "dereference thereof, and A denotes an aliased " &
 199                           "view of an object");
 200
 201    Non_Pointer_Block:
 202    begin
 203
 204       begin
 205          Obj0 := (3, "Bye");              -- OK: Obj0 not constrained.
 206          if Obj0 /= (3, "Bye") then
 207             Report.Failed
 208               ("Wrong value after aggregate assignment - Subtest 1");
 209          end if;
 210       exception
 211          when others =>
 212             Report.Failed ("Unexpected exception raised - Subtest 1");
 213       end;
 214
 215
 216       begin
 217          Obj1 := (3, "Bye");              -- OK: Obj1 not constrained.
 218          if Obj1 /= (3, "Bye") then
 219             Report.Failed
 220               ("Wrong value after aggregate assignment - Subtest 2");
 221          end if;
 222       exception
 223          when others =>
 224             Report.Failed ("Unexpected exception raised - Subtest 2");
 225       end;
 226
 227
 228       begin
 229          Obj2 := (3, "Bye");              -- C_E: Obj2 is constrained (D=>5).
 230          Avoid_Optimization_and_Fail (Obj2, "Subtest 3");
 231       exception
 232          when Constraint_Error => null;  -- Exception is expected.
 233       end;
 234
 235
 236       begin
 237          Obj3 := (3, "Bye");              -- C_E: Obj3 is constrained (D=>5).
 238          Avoid_Optimization_and_Fail (Obj3, "Subtest 4");
 239       exception
 240          when Constraint_Error => null;  -- Exception is expected.
 241       end;
 242
 243
 244       begin
 245          Obj4 := (3, "Bye");              -- C_E: Obj4 is constrained (D=>2).
 246          Avoid_Optimization_and_Fail (Obj4, "Subtest 5");
 247       exception
 248          when Constraint_Error => null;  -- Exception is expected.
 249       end;
 250
 251    exception
 252       when others => Report.Failed("Unexpected exception: Non_Pointer_Block");
 253    end Non_Pointer_Block;
 254
 255
 256    Pointer_Block:
 257    begin
 258
 259       begin
 260          Ptr1.all := (3, "Bye");        -- C_E: Ptr1.all is constrained (D=>5).
 261          Avoid_Optimization_and_Fail (Ptr1.all, "Subtest 6");
 262       exception
 263          when Constraint_Error => null; -- Exception is expected.
 264       end;
 265
 266
 267       begin
 268          Ptr2.all := (3, "Bye");        -- C_E: Ptr2.all is constrained (D=>2).
 269          Avoid_Optimization_and_Fail (Ptr2.all, "Subtest 7");
 270       exception
 271          when Constraint_Error => null; -- Exception is expected.
 272       end;
 273
 274
 275       begin
 276          Ptr3.all := (3, "Bye");        -- C_E: Ptr3.all is constrained (D=>5).
 277          Avoid_Optimization_and_Fail (Ptr3.all, "Subtest 8");
 278       exception
 279          when Constraint_Error => null; -- Exception is expected.
 280       end;
 281
 282
 283       begin
 284          Ptr4.all := (3, "Bye");        -- C_E: Ptr4.all is constrained (D=>2).
 285          Avoid_Optimization_and_Fail (Ptr4.all, "Subtest 9");
 286       exception
 287          when Constraint_Error => null; -- Exception is expected.
 288       end;
 289
 290    exception
 291       when others => Report.Failed("Unexpected exception: Pointer_Block");
 292    end Pointer_Block;
 293
 294
 295    Subprogram_Block:
 296    declare
 297       Is_Constrained : Boolean;
 298    begin
 299
 300       begin
 301          NP_Proc (Obj0);                 -- OK: Obj0 not constrained, can
 302          if Obj0 /= (3, "Bye") then      -- change discriminant value.
 303             Report.Failed
 304               ("Wrong value after aggregate assignment - Subtest 10");
 305          end if;
 306       exception
 307          when others =>
 308             Report.Failed ("Unexpected exception raised - Subtest 10");
 309       end;
 310
 311
 312       begin
 313          NP_Proc (Obj2);                 -- C_E: Obj2 is constrained (D=>5).
 314          Avoid_Optimization_and_Fail (Obj2, "Subtest 11");
 315       exception
 316          when Constraint_Error => null;  -- Exception is expected.
 317       end;
 318
 319
 320       begin
 321          NP_Proc (Obj3);                 -- C_E: Obj3 is constrained (D=>5).
 322          Avoid_Optimization_and_Fail (Obj3, "Subtest 12");
 323       exception
 324          when Constraint_Error => null;  -- Exception is expected.
 325       end;
 326
 327
 328       begin
 329          NP_Proc (Obj4);                 -- C_E: Obj4 is constrained (D=>2).
 330          Avoid_Optimization_and_Fail (Obj4, "Subtest 13");
 331       exception
 332          when Constraint_Error => null;  -- Exception is expected.
 333       end;
 334
 335
 336
 337       begin
 338          Is_Constrained := True;
 339          NP_Cons (Obj1, Is_Constrained);  -- Should return False, since Obj1
 340          if Is_Constrained then           -- is not constrained.
 341             Report.Failed ("Wrong result from 'Constrained - Subtest 14");
 342          end if;
 343       exception
 344          when others =>
 345             Report.Failed ("Unexpected exception raised - Subtest 14");
 346       end;
 347
 348
 349       begin
 350          Is_Constrained := False;
 351          NP_Cons (Obj2, Is_Constrained);  -- Should return True, Obj2 is
 352          if not Is_Constrained then       -- constrained.
 353             Report.Failed ("Wrong result from 'Constrained - Subtest 15");
 354          end if;
 355       exception
 356          when others =>
 357             Report.Failed ("Unexpected exception raised - Subtest 15");
 358       end;
 359
 360
 361
 362
 363       begin
 364          Is_Constrained := False;
 365          P_Cons (Ptr2, Is_Constrained);   -- Should return True, Ptr2.all
 366          if not Is_Constrained then       -- is constrained.
 367             Report.Failed ("Wrong result from 'Constrained - Subtest 16");
 368          end if;
 369       exception
 370          when others =>
 371             Report.Failed ("Unexpected exception raised - Subtest 16");
 372       end;
 373
 374
 375       begin
 376          Is_Constrained := False;
 377          P_Cons (Ptr3, Is_Constrained);   -- Should return True, Ptr3.all
 378          if not Is_Constrained then       -- is constrained.
 379             Report.Failed ("Wrong result from 'Constrained - Subtest 17");
 380          end if;
 381       exception
 382          when others =>
 383             Report.Failed ("Unexpected exception raised - Subtest 17");
 384       end;
 385
 386
 387    exception
 388       when others => Report.Failed("Exception raised in Subprogram_Block");
 389    end Subprogram_Block;
 390
 391
 392    Generic_Block:
 393    declare
 394
 395       type NUC is new UC;
 396
 397       Obj : NUC;
 398
 399
 400       package Instance_A is new Gen (NUC, Obj);
 401       package Instance_B is new Gen (UC, Obj2);
 402       package Instance_C is new Gen (UC, Obj3);
 403       package Instance_D is new Gen (UC, Obj4);
 404
 405    begin
 406
 407       begin
 408          Instance_A.Proc;                -- OK: Obj.D = 2.
 409          if Instance_A.F /= (2, "Fi") then
 410             Report.Failed
 411               ("Wrong value after aggregate assignment - Subtest 18");
 412          end if;
 413       exception
 414          when others =>
 415             Report.Failed ("Unexpected exception raised - Subtest 18");
 416       end;
 417
 418
 419       begin
 420          Instance_B.Proc;                -- C_E: Obj2.D = 5.
 421          Avoid_Optimization_and_Fail (Obj2, "Subtest 19");
 422       exception
 423          when Constraint_Error => null;  -- Exception is expected.
 424       end;
 425
 426
 427       begin
 428          Instance_C.Proc;                -- C_E: Obj3.D = 5.
 429          Avoid_Optimization_and_Fail (Obj3, "Subtest 20");
 430       exception
 431          when Constraint_Error => null;  -- Exception is expected.
 432       end;
 433
 434
 435       begin
 436          Instance_D.Proc;                -- OK: Obj4.D = 2.
 437          if Instance_D.F /= (2, "Fi") then
 438             Report.Failed
 439               ("Wrong value after aggregate assignment - Subtest 21");
 440          end if;
 441       exception
 442          when others =>
 443             Report.Failed ("Unexpected exception raised - Subtest 21");
 444       end;
 445
 446    exception
 447       when others => Report.Failed("Exception raised in Generic_Block");
 448    end Generic_Block;
 449
 450
 451    Report.Result;
 452
 453 end C3A0014;