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

-- C432001.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 extension aggregates may be used to specify values
--      for types that are record extensions. Check that the
--      type of the ancestor expression may be any nonlimited type that
--      is a record extension, including private types and private
--      extensions. Check that the type for the aggregate is
--      derived from the type of the ancestor expression.
--
-- TEST DESCRIPTION:
--
--      Two progenitor nonlimited record types are declared, one
--      nonprivate and one private. Using these as parent types,
--      all possible combinations of record extensions are declared
--      (Nonprivate record extension of nonprivate type, private
--      extension of nonprivate type, nonprivate record extension of
--      private type, and private extension of private type). Finally,
--      each of these types is extended using nonprivate record
--      extensions.
--
--      Extension of private types is done in packages other than
--      the ones containing the parent declaration. This is done
--      to eliminate errors with extension of the partial view of
--      a type, which is not an objective of this test.
--
--      All components of private types and private extensions are given
--      default values. This eliminates the need for separate subprograms
--      whose sole purpose is to place a value into a private record type.
--
--      Types that have been extended are checked using an object of their
--      parent type as the ancestor expression. For those types that
--      have been extended twice, using only nonprivate record extensions,
--      a check is made using an object of their grandparent type as
--      the ancestor expression.
--      
--      For each type, a subprogram is defined which checks the contents
--      of the parameter, which is a value of the record extension.
--      Components of nonprivate record extensions are checked against
--      passed-in parameters of the component type. Components of private
--      extensions are checked to ensure that they maintain their initial
--      values.
--
--      To check that the aggregate's type is derived from its ancestor,
--      each Check subprogram in turn calls the Check subprogram for
--      its parent type. Explicit conversion is used to convert the
--      record extension to the parent type.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!

with Report;
package C432001_0 is

   type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic);

   type N is tagged record
      How_Long_Ago : Natural := Report.Ident_Int(1);
      Era          : Eras := Cenozoic;
   end record;

   function Check (Rec : in N;
                   N   : in Natural;
                   E   : in Eras) return Boolean;

   type P is tagged private;

   function Check (Rec : in P) return Boolean;

private

   type P is tagged record
      How_Long_Ago : Natural := Report.Ident_Int(150);
      Era          : Eras := Mesozoic;
   end record;

end C432001_0;

package body C432001_0 is

   function Check (Rec : in P) return Boolean is
   begin
      return Rec.How_Long_Ago = 150 and Rec.Era = Mesozoic;
   end Check;

   function Check (Rec : in N;
                   N   : in Natural;
                   E   : in Eras) return Boolean is
   begin
      return Rec.How_Long_Ago = N and Rec.Era = E;
   end Check;

end C432001_0;

with C432001_0;
package C432001_1 is

   type Periods is
      (Aphebian, Helikian, Hadrynian,
       Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian,
       Triassic, Jurassic, Cretaceous,
       Tertiary, Quaternary);

   type N_N is new C432001_0.N with record
      Period : Periods := C432001_1.Quaternary;
   end record;

   function Check (Rec : in N_N;
                   N   : in Natural;
                   E   : in C432001_0.Eras;
                   P   : in Periods) return Boolean;

   type N_P is new C432001_0.N with private;

   function Check (Rec : in N_P) return Boolean;

   type P_N is new C432001_0.P with record
      Period : Periods := C432001_1.Jurassic;
   end record;

   function Check (Rec : in P_N;
                   P   : in Periods) return Boolean;

   type P_P is new C432001_0.P with private;

   function Check (Rec : in P_P) return Boolean;

   type P_P_Null is new C432001_0.P with null record;  

private

   type N_P is new C432001_0.N with record
      Period : Periods := C432001_1.Quaternary;
   end record;

   type P_P is new C432001_0.P with record
      Period : Periods := C432001_1.Jurassic;
   end record;

end C432001_1;

with Report;
package body C432001_1 is

   function Check (Rec : in N_N;
                   N   : in Natural;
                   E   : in C432001_0.Eras;
                   P   : in Periods) return Boolean is
   begin
      if not C432001_0.Check (C432001_0.N (Rec), N, E) then
         Report.Failed ("Conversion to parent type of " &
                        "nonprivate portion of " &
                        "nonprivate extension failed");
      end if;
      return Rec.Period = P;
   end Check;
   

   function Check (Rec : in N_P) return Boolean is
   begin
      if not C432001_0.Check (C432001_0.N (Rec), 1, C432001_0.Cenozoic) then
         Report.Failed ("Conversion to parent type of " &
                        "nonprivate portion of " &
                        "private extension failed");
      end if;
      return Rec.Period = C432001_1.Quaternary;
   end Check;

   function Check (Rec : in P_N;
                   P   : in Periods) return Boolean is
   begin
      if not C432001_0.Check (C432001_0.P (Rec)) then
         Report.Failed ("Conversion to parent type of " &
                        "private portion of " &
                        "nonprivate extension failed");
      end if;
      return Rec.Period = P;
   end Check;

   function Check (Rec : in P_P) return Boolean is
   begin
      if not C432001_0.Check (C432001_0.P (Rec)) then
         Report.Failed ("Conversion to parent type of " &
                        "private portion of " &
                        "private extension failed");
      end if;
      return Rec.Period = C432001_1.Jurassic;
   end Check;

end C432001_1;

with C432001_0;
with C432001_1;
package C432001_2 is

   -- All types herein are nonprivate extensions, since aggregates
   -- cannot be given for private extensions
   
   type N_N_N is new C432001_1.N_N with record
      Sample_On_Loan : Boolean;
   end record;

   function Check (Rec : in N_N_N;
                   N   : in Natural;
                   E   : in C432001_0.Eras;
                   P   : in C432001_1.Periods;
                   B   : in Boolean) return Boolean;

   type N_P_N is new C432001_1.N_P with record
      Sample_On_Loan : Boolean;
   end record;

   function Check (Rec : in N_P_N;
                   B   : Boolean) return Boolean;

   type P_N_N is new C432001_1.P_N with record
      Sample_On_Loan : Boolean;
   end record;

   function Check (Rec : in P_N_N;
                   P   : in C432001_1.Periods;
                   B   : Boolean) return Boolean;

   type P_P_N is new C432001_1.P_P with record
      Sample_On_Loan : Boolean;
   end record;

   function Check (Rec : in P_P_N;
                   B   : Boolean) return Boolean;

end C432001_2;

with Report;
package body C432001_2 is

   -- direct access to operator
   use type C432001_1.Periods;


   function Check (Rec : in N_N_N;
                   N   : in Natural;
                   E   : in C432001_0.Eras;
                   P   : in C432001_1.Periods;
                   B   : in Boolean) return Boolean is
   begin
      if not C432001_1.Check (C432001_1.N_N (Rec), N, E, P) then
         Report.Failed ("Conversion to parent " &
                        "nonprivate type extension " &
                        "failed");
      end if;
      return Rec.Sample_On_Loan = B;
   end Check;
   

   function Check (Rec : in N_P_N;
                   B   : Boolean) return Boolean is
   begin
      if not C432001_1.Check (C432001_1.N_P (Rec)) then
         Report.Failed ("Conversion to parent " &
                        "private type extension " &
                        "failed");
      end if;
      return Rec.Sample_On_Loan = B;
   end Check;

   function Check (Rec : in P_N_N;
                   P   : in C432001_1.Periods;
                   B   : Boolean) return Boolean is
   begin
      if not C432001_1.Check (C432001_1.P_N (Rec), P) then
         Report.Failed ("Conversion to parent " &
                        "nonprivate type extension " &
                        "failed");
      end if;
      return Rec.Sample_On_Loan = B;
   end Check;

   function Check (Rec : in P_P_N;
                   B   : Boolean) return Boolean is
   begin
      if not C432001_1.Check (C432001_1.P_P (Rec)) then
         Report.Failed ("Conversion to parent " &
                        "private type extension " &
                        "failed");
      end if;
      return Rec.Sample_On_Loan = B;
   end Check;

end C432001_2;


with C432001_0;
with C432001_1;
with C432001_2;
with Report;
procedure C432001 is

   N_Object : C432001_0.N := (How_Long_Ago => Report.Ident_Int(375),
                              Era          => C432001_0.Paleozoic);

   P_Object : C432001_0.P; -- default value is (150,
                           --                   C432001_0.Mesozoic)

   N_N_Object : C432001_1.N_N :=
      (N_Object with Period => C432001_1.Devonian);

   P_N_Object : C432001_1.P_N :=
      (P_Object with Period => C432001_1.Jurassic);

   N_P_Object : C432001_1.N_P; -- default is (1,
                               --             C432001_0.Cenozoic,
                               --             C432001_1.Quaternary)

   P_P_Object : C432001_1.P_P; -- default is (150,
                               --             C432001_0.Mesozoic,
                               --             C432001_1.Jurassic)

   P_P_Null_Ob:C432001_1.P_P_Null := (P_Object with null record);

   N_N_N_Object : C432001_2.N_N_N :=
      (N_N_Object with Sample_On_Loan => Report.Ident_Bool(True));

   N_P_N_Object : C432001_2.N_P_N :=
      (N_P_Object with Sample_On_Loan => Report.Ident_Bool(False));

   P_N_N_Object : C432001_2.P_N_N :=
      (P_N_Object with Sample_On_Loan => Report.Ident_Bool(True));

   P_P_N_Object : C432001_2.P_P_N :=
      (P_P_Object with Sample_On_Loan => Report.Ident_Bool(False));

   P_N_Object_2 : C432001_1.P_N := (C432001_0.P(P_N_N_Object)
                                    with C432001_1.Carboniferous);

   N_N_Object_2 : C432001_1.N_N := (C432001_0.N'(42,C432001_0.Precambrian)
                                    with C432001_1.Carboniferous);

begin

   Report.Test ("C432001", "Extension aggregates");

   -- check ultimate ancestor types

   if not C432001_0.Check (N_Object,
                           375,
                           C432001_0.Paleozoic) then
      Report.Failed ("Object of " &
                     "nonprivate type " &
                     "failed content check");
   end if;

   if not C432001_0.Check (P_Object) then
      Report.Failed ("Object of " &
                     "private type " &
                     "failed content check");
   end if;

   -- check direct type extensions

   if not C432001_1.Check (N_N_Object,
                           375,
                           C432001_0.Paleozoic,
                           C432001_1.Devonian) then
      Report.Failed ("Object of " &
                     "nonprivate extension of nonprivate type " &
                     "failed content check");
   end if;

   if not C432001_1.Check (N_P_Object) then
      Report.Failed ("Object of " &
                     "private extension of nonprivate type " &
                     "failed content check");
   end if;

   if not C432001_1.Check (P_N_Object,
                           C432001_1.Jurassic) then
      Report.Failed ("Object of " &
                     "nonprivate extension of private type " &
                     "failed content check");
   end if;

   if not C432001_1.Check (P_P_Object) then
      Report.Failed ("Object of " &
                     "private extension of private type " &
                     "failed content check");
   end if;

    if not C432001_1.Check (P_P_Null_Ob) then
      Report.Failed ("Object of " &
                     "private type " &
                     "failed content check");
   end if;


   -- check direct extensions of extensions

   if not C432001_2.Check (N_N_N_Object,
                           375,
                           C432001_0.Paleozoic,
                           C432001_1.Devonian,
                           True) then
      Report.Failed ("Object of " &
                     "nonprivate extension of nonprivate extension " &
                     "(of nonprivate parent) " &
                     "failed content check");
   end if;

   if not C432001_2.Check (N_P_N_Object, False) then
      Report.Failed ("Object of " &
                     "nonprivate extension of private extension " &
                     "(of nonprivate parent) " &
                     "failed content check");
   end if;

   if not C432001_2.Check (P_N_N_Object,
                           C432001_1.Jurassic,
                           True) then
      Report.Failed ("Object of " &
                     "nonprivate extension of nonprivate extension " &
                     "(of private parent) " &
                     "failed content check");
   end if;

   if not C432001_2.Check (P_P_N_Object, False) then
      Report.Failed ("Object of " &
                     "nonprivate extension of private extension " &
                     "(of private parent) " &
                     "failed content check");
   end if;

   -- check that the extension aggregate may specify an expression of
   -- a "grandparent" ancestor type

   -- types tested are derived through nonprivate extensions only
   -- (extension aggregates are not allowed if the path from the
   -- ancestor type wanders through a private extension)
   
   N_N_N_Object :=
      (N_Object with Period => C432001_1.Devonian,
                     Sample_On_Loan => Report.Ident_Bool(True));

   if not C432001_2.Check (N_N_N_Object,
                           375,
                           C432001_0.Paleozoic,
                           C432001_1.Devonian,
                           True) then
      Report.Failed ("Object of " &
                     "nonprivate extension " &
                     "of nonprivate ancestor " &
                     "failed content check");
   end if;

   P_N_N_Object :=
      (P_Object with Period => C432001_1.Jurassic,
                     Sample_On_Loan => Report.Ident_Bool(True));

   if not C432001_2.Check (P_N_N_Object,
                           C432001_1.Jurassic,
                           True) then
      Report.Failed ("Object of " &
                     "nonprivate extension " &
                     "of private ancestor " &
                     "failed content check");
   end if;

  -- Check additional cases
   if not C432001_1.Check (P_N_Object_2,
                           C432001_1.Carboniferous) then
      Report.Failed ("Additional Object of " &
                     "nonprivate extension of private type " &
                     "failed content check");
   end if;

   if not C432001_1.Check (N_N_Object_2,
                           42,
                           C432001_0.Precambrian,
                           C432001_1.Carboniferous) then
      Report.Failed ("Additional Object of " &
                     "nonprivate extension of nonprivate type " &
                     "failed content check");
   end if;

   Report.Result;

end C432001;