Subversion Repositories openrisc_me

-- C432004.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 the type of an extension aggregate may be derived from the

--      type of the ancestor part through multiple record extensions. Check

--      for ancestor parts that are subtype marks. Check that the type of the

--      ancestor part may be abstract.

--

-- TEST DESCRIPTION:

--      This test defines the following type hierarchies:

--

--                (A)                           (F)

--              Abstract                      Abstract

--           Tagged record                 Tagged private

--            /         \                   /          \

--           /          (C)               (G)           \

--         (B)        Abstract         Abstract         (H)

--       Record       private          record         Private

--      extension     extension        extension     extension

--          |             |                |             |

--         (D)           (E)              (I)           (J)

--       Record        Record           Record        Record

--      extension     extension        extension     extension

--

--      Extension aggregates for B, D, E, I, and J are constructed using each

--      of its ancestor types as the ancestor part (except for E and J, for

--      which only the immediate ancestor is used, since using A and F,

--      respectively, as the ancestor part would be illegal).

--

--      X1 : B := (A with ...);

--      X2 : D := (A with ...);         X5 : I := (F with ...);

--      X3 : D := (B with ...);         X6 : I := (G with ...);

--      X4 : E := (C with ...);         X7 : J := (H with ...);

--

--      For each assignment of an aggregate, the value of the target object is

--      checked to ensure that the proper values for each component were

--      assigned.

--

--

-- CHANGE HISTORY:

--      06 Dec 94   SAIC    ACVC 2.0

--

--!

package C432004_0 is

   type Drawers is record

      Building : natural;

   end record;

   type Location is access Drawers;

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

   type SampleType_A is abstract tagged record

      Era : Eras := Cenozoic;

      Loc : Location;

   end record;

   type SampleType_F is abstract tagged private;

   -- The following function is needed to verify the values of the

   -- private components.

   function TC_Correct_Result (Rec : SampleType_F'Class;

                               E   : Eras) return Boolean;

private

   type SampleType_F is abstract tagged record

      Era : Eras := Mesozoic;

   end record;

end C432004_0;

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

package body C432004_0 is

   function TC_Correct_Result (Rec : SampleType_F'Class;

                               E   : Eras) return Boolean is

   begin

      return (Rec.Era = E);

   end TC_Correct_Result;

end C432004_0;

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

with C432004_0;

package C432004_1 is

   type Periods is

      (Aphebian, Helikian, Hadrynian,

       Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian,

       Triassic, Jurassic, Cretaceous,

       Tertiary, Quaternary);

   type SampleType_B is new C432004_0.SampleType_A with record

      Period : Periods := Quaternary;

   end record;

   type SampleType_C is abstract new C432004_0.SampleType_A with private;

   -- The following function is needed to verify the values of the

   -- extension's private components.

   function TC_Correct_Result (Rec : SampleType_C'Class;

                               P   : Periods) return Boolean;

   type SampleType_G is abstract new C432004_0.SampleType_F with record

      Period : Periods := Jurassic;

      Loc    : C432004_0.Location;

   end record;

   type SampleType_H is new C432004_0.SampleType_F with private;

   -- The following function is needed to verify the values of the

   -- extension's private components.

   function TC_Correct_Result (Rec : SampleType_H'Class;

                               P   : Periods;

                               E   : C432004_0.Eras) return Boolean;

private

   type SampleType_C is abstract new C432004_0.SampleType_A with record

      Period : Periods := Quaternary;

   end record;

   type SampleType_H is new C432004_0.SampleType_F with record

      Period : Periods := Jurassic;

   end record;

end C432004_1;

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

package body C432004_1 is

   function TC_Correct_Result (Rec : SampleType_C'Class;

                               P   : Periods) return Boolean is

   begin

      return (Rec.Period = P);

   end TC_Correct_Result;

   -------------------------------------------------------------

   function TC_Correct_Result (Rec : SampleType_H'Class;

                               P   : Periods;

                               E   : C432004_0.Eras) return Boolean is

   begin

      return (Rec.Period = P) and C432004_0.TC_Correct_Result (Rec, E);

   end TC_Correct_Result;

end C432004_1;

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

with C432004_0;

with C432004_1;

package C432004_2 is

   -- All types herein are record extensions, since aggregates

   -- cannot be given for private extensions

   type SampleType_D is new C432004_1.SampleType_B with record

      Sample_On_Loan : Boolean := False;

   end record;

   type SampleType_E is new C432004_1.SampleType_C

     with null record;

   type SampleType_I is new C432004_1.SampleType_G with record

      Sample_On_Loan : Boolean := True;

   end record;

   type SampleType_J is new C432004_1.SampleType_H with record

      Sample_On_Loan : Boolean := True;

   end record;

end C432004_2;

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

with Report;

with C432004_0;

with C432004_1;

with C432004_2;

use  C432004_1;

use  C432004_2;

procedure C432004 is

   -- Variety of extension aggregates.

   -- Default values for the components of SampleType_A

   -- (Era => Cenozoic, Loc => null).

   Sample_B  :  SampleType_B

             := (C432004_0.SampleType_A with Period => Devonian);

   -- Default values from SampleType_A (Era => Cenozoic, Loc => null).

   Sample_D1 :  SampleType_D

             := (C432004_0.SampleType_A with Period => Cambrian,

                                     Sample_On_Loan => True);

   -- Default values from SampleType_A and SampleType_B

   -- (Era => Cenozoic, Loc => null, Period => Quaternary).

   Sample_D2 :  SampleType_D

             := (SampleType_B with Sample_On_Loan => True);

   -- Default values from SampleType_A and SampleType_C

   -- (Era => Cenozoic, Loc => null, Period => Quaternary).

   Sample_E  :  SampleType_E

             := (SampleType_C with null record);

   -- Default value from SampleType_F (Era => Mesozoic).

   Sample_I1 :  SampleType_I

             := (C432004_0.SampleType_F with Period => Tertiary,

                 Loc => new C432004_0.Drawers'(Building => 9),

                 Sample_On_Loan => False);

   -- Default values from SampleType_F and SampleType_G

   -- (Era => Mesozoic, Period => Jurassic, Loc => null).

   Sample_I2 :  SampleType_I

             := (SampleType_G with Sample_On_Loan => False);

   -- Default values from SampleType_H (Era => Mesozoic, Period => Jurassic).

   Sample_J  :  SampleType_J

             := (SampleType_H with Sample_On_Loan => False);

   use type C432004_0.Eras;

   use type C432004_0.Location;

begin

   Report.Test ("C432004", "Check that the type of an extension aggregate "  &

                "may be derived from the type of the ancestor part through " &

                "multiple record extensions");

   if Sample_B /= (C432004_0.Cenozoic, null, Devonian) then

      Report.Failed ("Object of record extension of abstract ancestor, " &

                     "SampleType_B, failed content check");

   end if;

   -------------------

   if Sample_D1 /= (Era => C432004_0.Cenozoic, Loc => null,

                    Period => Cambrian, Sample_On_Loan => True) then

      Report.Failed ("Object 1 of record extension of record extension, "  &

                     "of abstract ancestor, SampleType_D, failed content " &

                     "check");

   end if;

   -------------------

   if Sample_D2 /= (C432004_0.Cenozoic, null, Quaternary, True) then

      Report.Failed ("Object 2 of record extension of record extension, "  &

                     "of abstract ancestor, SampleType_D, failed content " &

                     "check");

   end if;

   -------------------

   if Sample_E.Era /= C432004_0.Cenozoic or

      Sample_E.Loc /= null               or

      not TC_Correct_Result (Sample_E, Quaternary) then

         Report.Failed ("Object of record extension of abstract private " &

                        "extension of abstract ancestor, SampleType_E, "  &

                        "failed content check");

   end if;

   -------------------

   if not C432004_0.TC_Correct_Result (Sample_I1, C432004_0.Mesozoic) or

     Sample_I1.Period         /= Tertiary                             or

     Sample_I1.Loc.Building   /= 9                                    or

     Sample_I1.Sample_On_Loan /= False                                then

       Report.Failed ("Object 1 of record extension of abstract record " &

                      "extension of abstract private ancestor, "         &

                      "SampleType_I, failed content check");

   end if;

   -------------------

   if not C432004_0.TC_Correct_Result (Sample_I2, C432004_0.Mesozoic) or

     Sample_I2.Period         /= Jurassic                             or

     Sample_I2.Loc            /= null                                 or

     Sample_I2.Sample_On_Loan /= False                                then

       Report.Failed ("Object 2 of record extension of abstract record " &

                      "extension of abstract private ancestor, "         &

                      "SampleType_I, failed content check");

   end if;

   -------------------

   if not TC_Correct_Result (Sample_J,

                             Jurassic,

                             C432004_0.Mesozoic) or

     Sample_J.Sample_On_Loan /= False            then

        Report.Failed ("Object of record extension of private extension " &

                       "of abstract private ancestor, SampleType_J, "     &

                       "failed content check");

   end if;

   Report.Result;

end C432004;