c432004.a

来自「linux下编程用 编译软件」· A 代码 · 共 320 行

-- 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;