path: root/gcc/testsuite/ada/acats/tests/c4/c432003.a

-- C432003.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 type of the ancestor part of an extension aggregate
--      has discriminants that are not inherited by the type of the aggregate,
--      and the ancestor part is a subtype mark that denotes a constrained
--      subtype, Constraint_Error is raised if: 1) any discriminant of the
--      ancestor has a different value than that specified for a corresponding
--      discriminant in the derived type definition for some ancestor of the
--      type of the aggregate, or 2) the value for the discriminant in the
--      record association list is not the value of the corresponding 
--      discriminant.  Check that the components of the value of the
--      aggregate not given by the record component association list are
--      initialized by default as for an object of the ancestor type.
--
-- TEST DESCRIPTION:
--      Consider:
--
--      type T (D1: ...) is tagged ...
--
--      type    DT is new T with ...
--      subtype ST is DT (D1 => 3);    -- Constrained subtype.
--
--      type NT1 (D2: ...) is new DT (D1 => D2) with null record;
--      type NT2 (D2: ...) is new DT (D1 => 6)  with null record;
--      type NT3           is new DT (D1 => 6)  with null record;
--
--      A: NT1 := (T  with D2 => 6); -- OK: T  is unconstrained.
--      B: NT1 := (DT with D2 => 6); -- OK: DT is unconstrained.
--      C: NT1 := (ST with D2 => 6); -- NO: ST.D1 /= D2.
--
--      D: NT2 := (T  with D2 => 4); -- OK: T  is unconstrained.
--      E: NT2 := (DT with D2 => 4); -- OK: DT is unconstrained.
--      F: NT2 := (ST with  . . . ); -- NO: ST.D1 /= DT.D1 as specified in NT2.
--
--      G: NT3 := (T  with D1 => 6); -- OK: T  is unconstrained.
--      H: NT3 := (DT with D1 => 6); -- OK: DT is unconstrained.
--      I: NT3 := (ST with D1 => 6); -- NO: ST.D1 /= DT.D1 as specified in NT3.
--
--      In A, B, D, E, G, and H the ancestor part is the name of an
--      unconstrained subtype, so this rule does not apply. In C, F, and I
--      the ancestor part (ST) is the name of a constrained subtype of DT,
--      which is itself a derived type of a discriminated tagged type T. ST
--      constrains the discriminant of DT (D1) to the value 3; thus, the
--      type of any extension aggregate for which ST is the ancestor part
--      must have an ancestor which also constrained D1 to 3. F and I raise
--      Constraint_Error because NT2 and NT3, respectively, constrain D1 to
--      6. C raises Constraint_Error because NT1 constrains D1 to the value
--      of D2, which is set to 6 in the record component association list of
--      the aggregate.
--
--      This test verifies each of the three scenarios above:
--
--         (1) Ancestor of type of aggregate constrains discriminant with
--             new discriminant.
--         (2) Ancestor of type of aggregate constrains discriminant with
--             value, and has a new discriminant part.
--         (3) Ancestor of type of aggregate constrains discriminant with
--             value, and has no discriminant part.
--
--      Verification is made for cases where the type of the aggregate is
--      once- and twice-removed from the type of the ancestor part.
--      
--      Additionally, a case is included where a new discriminant corresponds
--      to multiple discriminants of the type of the ancestor part.
--
--      To test the portion of the objective concerning "initialization by 
--      default," the test verifies that, after a successful aggregate
--      assignment, components not assigned an explicit value by the aggregate
--      contain the default values for the corresponding components of the
--      ancestor type.
--    
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      15 Dec 94   SAIC    Removed discriminant defaults from tagged types.
--      17 Nov 95   SAIC    ACVC 2.0.1 fixes: Corrected subtype constraint
--                          for component NT_C3.Str2. Added missing component
--                          checks. Removed record component update from
--                          Avoid_Optimization. Fixed incorrect component
--                          checks.
--      02 Dec 95   SAIC    ACVC 2.0.1 fixes: Corrected Failed comment for
--                          Q case.
--
--!

package C432003_0 is

   Default_String : constant String := "This is a default string"; -- len = 24
   Another_String : constant String := "Another default string";   -- len = 22

   subtype Length is Natural range 0..255;

   type ROOT (D1 : Length) is tagged 
      record
         S1  : String (1..D1) := Default_String(1..D1);
         Acc : Natural := 356;
      end record;

   procedure Avoid_Optimization (Rec : in out ROOT); -- Inherited by all type
                                                     -- extensions.

   type Unconstrained_Der is new ROOT with 
      record
         Str1 : String(1..5) := "abcde";
      end record;

   subtype Constrained_Subtype is Unconstrained_Der (D1 => 10);

   type NT_A1 (D2 : Length) is new Unconstrained_Der (D1 => D2) with 
      record
         S2 : String(1..D2);         -- Inherited discrim. constrained by
      end record;                    -- new discriminant.

   type NT_A2 (D3 : Length) is new NT_A1 (D2 => D3) with 
      record
         S3 : String(1..D3);         -- Inherited discrim. constrained by
      end record;                    -- new discriminant.


   type NT_B1 (D2 : Length) is new Unconstrained_Der (D1 => 5) with 
      record
         S2 : String(1..D2);         -- Inherited discrim. constrained by
      end record;                    -- explicit value.

   type NT_B2 (D3 : Length) is new NT_B1 (D2 => 10) with 
      record
         S3 : String(1..D3);         -- Inherited discrim. constrained by
      end record;                    -- explicit value.

   type NT_B3 (D2 : Length) is new Unconstrained_Der (D1 => 10) with
      record
         S2 : String(1..D2);
      end record;


   type NT_C1 is new Unconstrained_Der (D1 => 5) with 
      record
         Str2 : String(1..5);         -- Inherited discrim. constrained
      end record;                     -- No new value.

   type NT_C2 (D2 : Length) is new NT_C1 with 
      record
         S2 : String(1..D2);          -- Inherited discrim. not further
      end record;                     -- constrained, new discriminant.

   type NT_C3 is new Unconstrained_Der(D1 => 10) with
      record
         Str2 : String(1..5);
      end record;


   type MULTI_ROOT (D1 : Length; D2 : Length) is tagged
      record
         S1 : String (1..D1) := Default_String(1..D1);
         S2 : String (1..D2) := Another_String(1..D2);
      end record;

   procedure Avoid_Optimization (Rec : in out MULTI_ROOT); -- Inherited by all
                                                           -- type extensions.
                                                           
   type Mult_Unconstr_Der is new MULTI_ROOT with
      record
         Str1 : String(1..8) := "AbCdEfGh";  -- Derived, no constraints.
      end record;

   -- Subtypes with constrained discriminants.
   subtype Mult_Constr_Sub1 is Mult_Unconstr_Der(D1 => 15,  -- Disc. have
                                                 D2 => 20); -- diff values

   subtype Mult_Constr_Sub2 is Mult_Unconstr_Der(D1 => 15,  -- Disc. have
                                                 D2 => 15); -- same value

   type Mult_NT_A1 (D3 : Length) is 
     new Mult_Unconstr_Der (D1 => D3, D2 => D3) with
      record
         S3 : String(1..D3);      -- Both inherited discriminants constrained
      end record;                 -- by new discriminant.

end C432003_0;


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


with Report;
package body C432003_0 is

   procedure Avoid_Optimization (Rec : in out ROOT) is
   begin
      Rec.S1 := Report.Ident_Str(Rec.S1);
   end Avoid_Optimization;

   procedure Avoid_Optimization (Rec : in out MULTI_ROOT) is
   begin
      Rec.S1 := Report.Ident_Str(Rec.S1);
   end Avoid_Optimization;

end C432003_0;


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


with C432003_0;
with Report;
procedure C432003 is
begin

   Report.Test("C432003", "Extension aggregates where ancestor part "      &
                          "is a subtype mark that denotes a constrained "  &
                          "subtype causing Constraint_Error if any "       &
                          "discriminant of the ancestor has a different "  &
                          "value than that specified for a corresponding " &
                          "discriminant in the derived type definition "   &
                          "for some ancestor of the type of the aggregate");

   Test_Block:
      declare

         -- Variety of string object declarations.
         String2  : String(1..2)  := Report.Ident_Str("12");
         String5  : String(1..5)  := Report.Ident_Str("12345");
         String8  : String(1..8)  := Report.Ident_Str("AbCdEfGh");
         String10 : String(1..10) := Report.Ident_Str("1234567890");
         String15 : String(1..15) := Report.Ident_Str("123456789012345");
         String20 : String(1..20) := Report.Ident_Str("12345678901234567890");

      begin


         begin
            declare
               A : C432003_0.NT_A1 :=                                  -- OK
                     (C432003_0.ROOT with D2   => 5,
                                          Str1 => "cdefg",
                                          S2   => String5);
            begin
               C432003_0.Avoid_Optimization(A);
               if A.Acc  /= 356       or
                  A.Str1 /= "cdefg"   or
                  A.S2   /= String5   or 
                  A.D2   /= 5         or
                  A.S1   /= C432003_0.Default_String(1..5)
               then
                  Report.Failed("Incorrect object values for Object A");
               end if;
            end;
         exception
            when Constraint_Error =>
               Report.Failed("Constraint_Error raised for Object A");
         end;


         begin
            declare
               C: C432003_0.NT_A1 :=                                   -- OK
                    (C432003_0.Constrained_Subtype with D2 => 10,
                                                        S2 => String10);
            begin
               C432003_0.Avoid_Optimization(C);
               if C.D2   /= 10        or  C.Acc /= 356      or
                  C.Str1 /= "abcde"   or  C.S2  /= String10 or
                  C.S1   /= C432003_0.Default_String(1..10)
               then
                  Report.Failed("Incorrect object values for Object C");
               end if;
            end;
         exception
            when Constraint_Error =>
               Report.Failed("Constraint_Error raised for Object C");
         end;


         begin
            declare 
               D: C432003_0.NT_A1 :=                                  -- C_E
                    (C432003_0.Constrained_Subtype with 
                       D2 => Report.Ident_Int(5),
                       S2 => String5);
            begin
               C432003_0.Avoid_Optimization(D);
               Report.Failed("Constraint_Error not raised for Object D");
            end;
         exception
            when Constraint_Error =>
               null;  -- Raise of Constraint_Error is expected.
         end;


         begin
            declare
               E: C432003_0.NT_A2 :=                                   -- OK
                    (C432003_0.Constrained_Subtype with D3 => 10,
                                                        S2 => String10,
                                                        S3 => String10);
            begin
               C432003_0.Avoid_Optimization(E);
               if E.D3   /= 10        or  E.Acc /= 356        or
                  E.Str1 /= "abcde"   or  E.S2  /= String10   or
                  E.S3   /= String10  or
                  E.S1   /= C432003_0.Default_String(1..10)
               then
                  Report.Failed("Incorrect object values for Object E");
               end if;
            end;
         exception
            when Constraint_Error =>
               Report.Failed("Constraint_Error raised for Object E");
         end;


         begin
            declare
               F: C432003_0.NT_A2 :=                                  -- C_E
                    (C432003_0.Constrained_Subtype with 
                       D3 => Report.Ident_Int(5),  
                       S2 => String5,
                       S3 => String5);
            begin
               C432003_0.Avoid_Optimization(F);
               Report.Failed("Constraint_Error not raised for Object F");
            end;
         exception
            when Constraint_Error =>
               null;  -- Raise of Constraint_Error is expected.
         end;


         begin
            declare
               G: C432003_0.NT_B2 :=                                  -- OK
                    (C432003_0.ROOT with D3   => 5,     
                                         Str1 => "cdefg",
                                         S2   => String10,
                                         S3   => String5);
            begin
               C432003_0.Avoid_Optimization(G);
               if G.D3   /= 5         or  G.Acc /= 356       or
                  G.Str1 /= "cdefg"   or  G.S2  /= String10  or
                  G.S3   /= String5   or
                  G.S1   /= C432003_0.Default_String(1..5)
               then
                  Report.Failed("Incorrect object values for Object G");
               end if;
            end;
         exception
            when Constraint_Error =>
               Report.Failed("Constraint_Error raised for Object G");
         end;


         begin
            declare
               H: C432003_0.NT_B3 :=                                    -- OK
                    (C432003_0.Unconstrained_Der with D2 => 5,
                                                      S2 => String5);
            begin
               C432003_0.Avoid_Optimization(H);
               if H.D2   /= 5          or  H.Acc /= 356      or
                  H.Str1 /= "abcde"    or  H.S2  /= String5  or
                  H.S1   /= C432003_0.Default_String(1..10)
               then
                  Report.Failed("Incorrect object values for Object H");
               end if;
            end;
         exception
            when Constraint_Error =>
               Report.Failed("Constraint_Error raised for Object H");
         end;


         begin
            declare
               I: C432003_0.NT_B1 :=                                  -- C_E
                    (C432003_0.Constrained_Subtype with 
                        D2 => Report.Ident_Int(10),
                        S2 => String10);
            begin
               C432003_0.Avoid_Optimization(I);
               Report.Failed("Constraint_Error not raised for Object I");
            end;
         exception
            when Constraint_Error =>
               null;  -- Raise of Constraint_Error is expected.
         end;


         begin
            declare
               J: C432003_0.NT_B2 :=                                  -- C_E
                    (C432003_0.Constrained_Subtype with 
                       D3 => Report.Ident_Int(10),
                       S2 => String10,
                       S3 => String10);
            begin
               C432003_0.Avoid_Optimization(J);
               Report.Failed("Constraint_Error not raised by Object J");
            end;
         exception
            when Constraint_Error =>
               null;  -- Raise of Constraint_Error is expected.
         end;


         begin
            declare
               K: C432003_0.NT_B3 :=                                   -- OK
                    (C432003_0.Constrained_Subtype with D2 => 5,
                                                        S2 => String5);
            begin
               C432003_0.Avoid_Optimization(K);
               if K.D2   /= 5          or  K.Acc /= 356       or
                  K.Str1 /= "abcde"    or  K.S2  /= String5   or
                  K.S1   /= C432003_0.Default_String(1..10)
               then
                  Report.Failed("Incorrect object values for Object K");
               end if;
            end;
         exception
            when Constraint_Error =>
               Report.Failed("Constraint_Error raised for Object K");
         end;


         begin
            declare
               M: C432003_0.NT_C2 :=                                   -- OK
                    (C432003_0.ROOT with D2   => 10,
                                         Str1 => "cdefg",
                                         Str2 => String5,
                                         S2   => String10);
            begin
               C432003_0.Avoid_Optimization(M);
               if M.D2   /= 10         or  M.Acc /= 356       or
                  M.Str1 /= "cdefg"    or  M.S2  /= String10  or
                  M.Str2 /= String5    or
                  M.S1   /= C432003_0.Default_String(1..5)
               then
                  Report.Failed("Incorrect object values for Object M");
               end if;
            end;
         exception
            when Constraint_Error =>
               Report.Failed("Constraint_Error raised for Object M");
         end;


         begin
            declare
               O: C432003_0.NT_C1 :=                                  -- C_E
                    (C432003_0.Constrained_Subtype with 
                       Str2 => Report.Ident_Str(String5));
            begin
               C432003_0.Avoid_Optimization(O);
               Report.Failed("Constraint_Error not raised for Object O");
            end;
         exception
            when Constraint_Error =>
               null;  -- Raise of Constraint_Error is expected.
         end;


         begin
            declare
               P: C432003_0.NT_C2 :=                                  -- C_E
                    (C432003_0.Constrained_Subtype with 
                       D2   => Report.Ident_Int(10),
                       Str2 => String5,
                       S2   => String10);
            begin
               C432003_0.Avoid_Optimization(P);
               Report.Failed("Constraint_Error not raised by Object P");
            end;
         exception
            when Constraint_Error =>
               null;  -- Raise of Constraint_Error is expected.
         end;


         begin
            declare
               Q: C432003_0.NT_C3 := 
                  (C432003_0.Constrained_Subtype with Str2 => String5);  -- OK
            begin
               C432003_0.Avoid_Optimization(Q);
               if Q.Str2 /= String5  or  
                  Q.Acc  /= 356      or  
                  Q.Str1 /= "abcde"  or
                  Q.D1   /= 10       or
                  Q.S1   /= C432003_0.Default_String(1..10)
               then
                  Report.Failed("Incorrect object values for Object Q");
               end if;
            end;
         exception
            when Constraint_Error =>
               Report.Failed("Constraint_Error raised for Object Q");
         end;


         -- The following cases test where a new discriminant corresponds
         -- to multiple discriminants of the type of the ancestor part.

         begin
            declare
               S: C432003_0.Mult_NT_A1 :=                              -- OK
                    (C432003_0.Mult_Unconstr_Der with D3 => 15,
                                                      S3 => String15);
            begin
               C432003_0.Avoid_Optimization(S);
               if S.S1   /= C432003_0.Default_String(1..15)  or  
                  S.Str1 /= String8                          or
                  S.S2   /= C432003_0.Another_String(1..15)  or  
                  S.S3   /= String15                         or
                  S.D3   /= 15
               then
                  Report.Failed("Incorrect object values for Object S");
               end if;
            end;
         exception
            when Constraint_Error =>
               Report.Failed("Constraint_Error raised for Object S");
         end;


         begin
            declare
               U: C432003_0.Mult_NT_A1 :=                             -- C_E
                    (C432003_0.Mult_Constr_Sub1 with 
                       D3 => Report.Ident_Int(15),
                       S3 => String15);
            begin
               C432003_0.Avoid_Optimization(U);
               Report.Failed("Constraint_Error not raised for Object U");
            end;
         exception
            when Constraint_Error =>
               null;  -- Raise of Constraint_Error is expected.
         end;


         begin
            declare
               V: C432003_0.Mult_NT_A1 :=                              -- OK
                    (C432003_0.Mult_Constr_Sub2 with D3 => 15,
                                                     S3 => String15);
            begin
               C432003_0.Avoid_Optimization(V);
               if V.D3   /= 15        or  
                  V.Str1 /= String8   or
                  V.S3   /= String15  or
                  V.S1   /= C432003_0.Default_String(1..15) or
                  V.S2   /= C432003_0.Another_String(1..15)
               then
                  Report.Failed("Incorrect object values for Object V");
               end if;
            end;
         exception
            when Constraint_Error =>
               Report.Failed("Constraint_Error raised for Object V");
         end;


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

      Report.Result;

end C432003;