path: root/gcc/testsuite/ada/acats/tests/c3/c3a0014.a

-- C3A0014.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--      Check that if the view defined by an object declaration is aliased,
--      and the type of the object has discriminants, then the object is
--      constrained by its initial value even if its nominal subtype is
--      unconstrained.
--
--      Check that the attribute A'Constrained returns True if A is a formal
--      out or in out parameter, or dereference thereof, and A denotes an
--      aliased view of an object.
--
-- TEST DESCRIPTION:
--      These rules apply to objects of a record type with defaulted
--      discriminants, which may be unconstrained variables. If such a
--      variable is declared to be aliased, then it is constrained by its
--      initial value, and the value of the discriminant cannot be changed
--      for the life of the variable.
--
--      The rules do not apply to aliased component types because if such
--      types are discriminated they must be constrained.
--
--      A'Constrained returns True if A denotes a constant, value, or
--      constrained variable. Since aliased objects are constrained, it must
--      return True if the actual parameter corresponding to a formal
--      parameter A is an aliased object. The objective only mentions formal
--      parameters of mode out and in out, since parameters of mode in are
--      by definition constant, and would result in True anyway.
--
--      This test declares aliased objects of a nominally unconstrained
--      record subtype, both with and without initialization expressions.
--      It also declares access values which point to such objects. It then
--      checks that Constraint_Error is raised if an attempt is made to
--      change the discriminant value of an aliased object, either directly
--      or via a dereference of an access value. For aliased objects, this
--      check is also performed for subprogram parameters of mode out.
--
--      The test also passes aliased objects and access values which point
--      to such objects as actuals to subprograms and verifies, for parameter
--      modes out and in out, that P'Constrained returns true if P is the
--      corresponding formal parameter or a dereference thereof.
--
--      Additionally, the test declares a generic package which declares a
--      an aliased object of a formal derived unconstrained type, which is
--      is initialized with the value of a formal object of that type.
--      procedure declared within the generic assigns a value to the object
--      which has the same discriminant value as the formal derived type's
--      ancestor type. The generic is instantiated with various actuals
--      for the formal object, and the procedure is called. The test verifies
--      that Constraint_Error is raised if the discriminant values of the
--      actual corresponding to the formal object and the value assigned
--      by the procedure are not equal.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      16 Nov 95   SAIC    ACVC 2.0.1 fixes: Corrected numerous errors.
--
--!

package C3A0014_0 is

   subtype Reasonable is Integer range 1..10;
                                          -- Unconstrained (sub)type.
   type UC (D: Reasonable := 2) is record -- Discriminant default.
      S: String (1 .. D) := "Hi";         -- Default value.
   end record;

   type AUC is access all UC;

   -- Nominal subtype is unconstrained for the following:

   Obj0 :         UC;                  -- An unconstrained object.

   Obj1 :         UC := (5, "Hello");  -- Non-aliased with initialization,
                                       -- an unconstrained object.

   Obj2 : aliased UC := (5, "Hello");  -- Aliased with initialization,
                                       -- a constrained object.

   Obj3 :         UC renames Obj2;     -- Aliased (renaming of aliased view),
                                       -- a constrained object.
   Obj4 : aliased UC;                  -- Aliased without initialization, Obj4
                                       -- constrained here to initial value
                                       -- taken from default for type.

   Ptr1 : AUC := new UC'(Obj1);
   Ptr2 : AUC := new UC;
   Ptr3 : AUC := Obj3'Access;
   Ptr4 : AUC := Obj4'Access;


   procedure NP_Proc (A:    out UC);
   procedure NP_Cons (A: in out UC;  B: out Boolean);
   procedure P_Cons  (A:    out AUC; B: out Boolean);


   generic
      type FT is new UC;
      FObj : in out FT;
   package Gen is
      F  : aliased FT := FObj;     -- Constrained if FT has discriminants.
      procedure Proc;
   end Gen;


   procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String );


end C3A0014_0;


  --=======================================================================--

with Report;

package body C3A0014_0 is

   procedure NP_Proc (A: out UC) is
   begin
      A := (3, "Bye");
   end NP_Proc;

   procedure NP_Cons (A: in out UC; B: out Boolean) is
   begin
      B := A'Constrained; 
   end NP_Cons;

   procedure P_Cons (A: out AUC; B: out Boolean) is
   begin
      B := A.all'Constrained; 
   end P_Cons;


   package body Gen is
     
      procedure Proc is
      begin
         F := (2, "Fi");
      end Proc;

   end Gen;


   procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ) is
      Default : UC := (1, "!"); -- Unique value.
   begin                       
      if P = Default then       -- Both If branches can't do the same thing.
         Report.Failed  (Msg & ": Constraint_Error not raised");
      else                      -- Subtests should always select this path.
         Report.Failed ("Constraint_Error not raised " & Msg);
      end if;
   end Avoid_Optimization_and_Fail;


end C3A0014_0;


  --=======================================================================--


with C3A0014_0;  use C3A0014_0;
with Report;

procedure C3A0014 is
begin

   Report.Test("C3A0014", "Check that if the view defined by an object "   &
                          "declaration is aliased, and the type of the "   &
                          "object has discriminants, then the object is "  &
                          "constrained by its initial value even if its "  &
                          "nominal subtype is unconstrained.  Check that " &
                          "the attribute A'Constrained returns True if A " &
                          "is a formal out or in out parameter, or "       &
                          "dereference thereof, and A denotes an aliased " &
                          "view of an object");

   Non_Pointer_Block:
   begin

      begin
         Obj0 := (3, "Bye");              -- OK: Obj0 not constrained.
         if Obj0 /= (3, "Bye") then
            Report.Failed 
              ("Wrong value after aggregate assignment - Subtest 1");
         end if;
      exception
         when others => 
            Report.Failed ("Unexpected exception raised - Subtest 1");
      end;


      begin
         Obj1 := (3, "Bye");              -- OK: Obj1 not constrained.
         if Obj1 /= (3, "Bye") then
            Report.Failed
              ("Wrong value after aggregate assignment - Subtest 2");
         end if;
      exception
         when others => 
            Report.Failed ("Unexpected exception raised - Subtest 2");
      end;


      begin
         Obj2 := (3, "Bye");              -- C_E: Obj2 is constrained (D=>5).
         Avoid_Optimization_and_Fail (Obj2, "Subtest 3");
      exception
         when Constraint_Error => null;  -- Exception is expected.
      end;


      begin
         Obj3 := (3, "Bye");              -- C_E: Obj3 is constrained (D=>5).
         Avoid_Optimization_and_Fail (Obj3, "Subtest 4");
      exception
         when Constraint_Error => null;  -- Exception is expected.
      end;


      begin
         Obj4 := (3, "Bye");              -- C_E: Obj4 is constrained (D=>2).
         Avoid_Optimization_and_Fail (Obj4, "Subtest 5");
      exception
         when Constraint_Error => null;  -- Exception is expected.
      end;

   exception
      when others => Report.Failed("Unexpected exception: Non_Pointer_Block");
   end Non_Pointer_Block;


   Pointer_Block:
   begin
   
      begin
         Ptr1.all := (3, "Bye");        -- C_E: Ptr1.all is constrained (D=>5).
         Avoid_Optimization_and_Fail (Ptr1.all, "Subtest 6");
      exception
         when Constraint_Error => null; -- Exception is expected.
      end;


      begin
         Ptr2.all := (3, "Bye");        -- C_E: Ptr2.all is constrained (D=>2).
         Avoid_Optimization_and_Fail (Ptr2.all, "Subtest 7");
      exception
         when Constraint_Error => null; -- Exception is expected. 
      end;


      begin
         Ptr3.all := (3, "Bye");        -- C_E: Ptr3.all is constrained (D=>5).
         Avoid_Optimization_and_Fail (Ptr3.all, "Subtest 8");
      exception
         when Constraint_Error => null; -- Exception is expected. 
      end;


      begin
         Ptr4.all := (3, "Bye");        -- C_E: Ptr4.all is constrained (D=>2).
         Avoid_Optimization_and_Fail (Ptr4.all, "Subtest 9");
      exception
         when Constraint_Error => null; -- Exception is expected. 
      end;

   exception
      when others => Report.Failed("Unexpected exception: Pointer_Block");
   end Pointer_Block;


   Subprogram_Block:
   declare
      Is_Constrained : Boolean;
   begin

      begin
         NP_Proc (Obj0);                 -- OK: Obj0 not constrained, can
         if Obj0 /= (3, "Bye") then      -- change discriminant value.
            Report.Failed 
              ("Wrong value after aggregate assignment - Subtest 10");
         end if;
      exception
         when others => 
            Report.Failed ("Unexpected exception raised - Subtest 10");
      end;


      begin
         NP_Proc (Obj2);                 -- C_E: Obj2 is constrained (D=>5).
         Avoid_Optimization_and_Fail (Obj2, "Subtest 11");      
      exception
         when Constraint_Error => null;  -- Exception is expected.
      end;


      begin
         NP_Proc (Obj3);                 -- C_E: Obj3 is constrained (D=>5).
         Avoid_Optimization_and_Fail (Obj3, "Subtest 12");
      exception
         when Constraint_Error => null;  -- Exception is expected.
      end;


      begin
         NP_Proc (Obj4);                 -- C_E: Obj4 is constrained (D=>2).
         Avoid_Optimization_and_Fail (Obj4, "Subtest 13");
      exception
         when Constraint_Error => null;  -- Exception is expected.
      end;



      begin
         Is_Constrained := True;
         NP_Cons (Obj1, Is_Constrained);  -- Should return False, since Obj1
         if Is_Constrained then           -- is not constrained.
            Report.Failed ("Wrong result from 'Constrained - Subtest 14");
         end if;
      exception
         when others => 
            Report.Failed ("Unexpected exception raised - Subtest 14");
      end;


      begin
         Is_Constrained := False;
         NP_Cons (Obj2, Is_Constrained);  -- Should return True, Obj2 is
         if not Is_Constrained then       -- constrained.
            Report.Failed ("Wrong result from 'Constrained - Subtest 15");
         end if;
      exception
         when others => 
            Report.Failed ("Unexpected exception raised - Subtest 15");
      end;




      begin
         Is_Constrained := False;
         P_Cons (Ptr2, Is_Constrained);   -- Should return True, Ptr2.all
         if not Is_Constrained then       -- is constrained.
            Report.Failed ("Wrong result from 'Constrained - Subtest 16");
         end if;
      exception
         when others => 
            Report.Failed ("Unexpected exception raised - Subtest 16");
      end;


      begin
         Is_Constrained := False;
         P_Cons (Ptr3, Is_Constrained);   -- Should return True, Ptr3.all
         if not Is_Constrained then       -- is constrained.
            Report.Failed ("Wrong result from 'Constrained - Subtest 17");
         end if;
      exception
         when others => 
            Report.Failed ("Unexpected exception raised - Subtest 17");
      end;


   exception
      when others => Report.Failed("Exception raised in Subprogram_Block");
   end Subprogram_Block;


   Generic_Block:
   declare

      type NUC is new UC;

      Obj : NUC;


      package Instance_A is new Gen (NUC, Obj);
      package Instance_B is new Gen (UC, Obj2);
      package Instance_C is new Gen (UC, Obj3);
      package Instance_D is new Gen (UC, Obj4);

   begin

      begin
         Instance_A.Proc;                -- OK: Obj.D = 2.
         if Instance_A.F /= (2, "Fi") then
            Report.Failed 
              ("Wrong value after aggregate assignment - Subtest 18");
         end if;
      exception
         when others => 
            Report.Failed ("Unexpected exception raised - Subtest 18");
      end;


      begin
         Instance_B.Proc;                -- C_E: Obj2.D = 5.
         Avoid_Optimization_and_Fail (Obj2, "Subtest 19");
      exception
         when Constraint_Error => null;  -- Exception is expected.
      end;


      begin
         Instance_C.Proc;                -- C_E: Obj3.D = 5.
         Avoid_Optimization_and_Fail (Obj3, "Subtest 20");
      exception
         when Constraint_Error => null;  -- Exception is expected.
      end;


      begin
         Instance_D.Proc;                -- OK: Obj4.D = 2.
         if Instance_D.F /= (2, "Fi") then
            Report.Failed 
              ("Wrong value after aggregate assignment - Subtest 21");
         end if;
      exception
         when others => 
            Report.Failed ("Unexpected exception raised - Subtest 21");
      end;

   exception
      when others => Report.Failed("Exception raised in Generic_Block");
   end Generic_Block;


   Report.Result;

end C3A0014;