c452001.a

来自「linux下编程用 编译软件」· A 代码 · 共 708 行 · 第 1/2 页

-- C452001.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:
--      For a type extension, check that predefined equality is defined in
--      terms of the primitive equals operator of the parent type and any
--      tagged components of the extension part.
--
--      For other composite types, check that the primitive equality operator
--      of any matching tagged components is used to determine equality of the
--      enclosing type.
--
--      For private types, check that predefined equality is defined in
--      terms of the user-defined (primitive) operator of the full type if
--      the full type is tagged. The partial view of the type may be
--      tagged or untagged. Check that predefined equality for a private
--      type whose full view is untagged is defined in terms of the
--      predefined equality operator of its full type.
--
-- TEST DESCRIPTION:
--      Tagged types are declared and used as components in several
--      differing composite type declarations, both tagged and untagged.
--      To differentiate between predefined and primitive equality
--      operations, user-defined equality operators are declared for
--      each component type that is to contribute to the equality
--      operator of the composite type that houses it. All user-defined
--      equality operations are designed to yield the opposite result
--      from the predefined operator, given the same component values.
--
--      For cases where primitive equality is to be incorporated into
--      equality for the enclosing composite type, values are assigned
--      to the component type so that user-defined equality will return
--      True. If predefined equality is to be used instead, then the
--      same strategy results in the equality operator returning False.
--
--      When equality for a type incorporates the user-defined equality
--      operator of one of its component types, the resulting operator
--      is considered to be the predefined operator of the composite type.
--      This case is confirmed by defining an tagged component of an
--      untagged composite type, then using the resulting untagged type
--      as a component of another composite type. The user-defined operator
--      for the lowest level should still be called.
--
--      Three cases are set up to test private types:
--
--                        Case 1        Case 2      Case 3
--         partial view:  tagged       untagged    untagged
--         full view:     tagged        tagged     untagged
--
--      Types are declared for each of the above cases and user-defined
--      (primitive) operators are declared following the full type
--      declaration of each type (i.e., in the private part).
--
--      Values are assigned into objects of these types using the same
--      strategy outlined above. Cases 1 and 2 should execute the
--      user-defined operator. Case 3 should ignore the user-defined
--      operator and user predefined equality for the type.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      19 Dec 94   SAIC    Removed RM references from objective text.
--      15 Nov 95   SAIC    Fixed for 2.0.1
--      04 NOV 96   SAIC    Typographical revision
--
--!

package c452001_0 is

   type Point is
      record
         X : Integer := 0;
         Y : Integer := 0;
      end record;

   type Circle is tagged
      record
         Center : Point;
         Radius : Integer;
      end record;

   function "=" (L, R : Circle) return Boolean;

   type Colors is (Red, Orange, Yellow, Green, Blue, Purple, Black, White);

   type Colored_Circle is new Circle
      with record
         Color : Colors := White;
      end record;

   function "=" (L, R : Colored_Circle) return Boolean;
   -- Override predefined equality for this tagged type. Predefined
   -- equality should incorporate user-defined (primitive) equality
   -- from type Circle. See C340001 for a test of that feature.

   -- Equality is overridden to ensure that predefined equality 
   -- incorporates this user-defined function for
   -- any composite type with Colored_Circle as a component type.
   -- (i.e., the type extension is recognized as a tagged type for
   -- the purpose of defining predefined equality for the composite type).

end C452001_0;

package body c452001_0 is

   function "=" (L, R : Circle) return Boolean is
   begin
      return L.Radius = R.Radius; -- circles are same size
   end "=";

   function "=" (L, R : Colored_Circle) return Boolean is
   begin
      return Circle(L) = Circle(R);
   end "=";

end C452001_0;

with C452001_0;
package C452001_1 is

   type Planet is tagged record
      Name : String (1..15);
      Representation : C452001_0.Colored_Circle;
   end record;

   -- Type Planet will be used to check that predefined equality
   -- for a tagged type with a tagged component incorporates
   -- user-defined equality for the component type.

   type TC_Planet is new Planet with null record;

   -- A "copy" of Planet. Used to create a type extension. An "="
   -- operator will be defined for this type that should be
   -- incorporated by the type extension.

   function "=" (Arg1, Arg2 : in TC_Planet) return Boolean;

   type Craters is array (1..3) of C452001_0.Colored_Circle;

   -- An array type (untagged) with tagged components

   type Moon is new TC_Planet
     with record
        Crater : Craters;
     end record;
     
   -- A tagged record type. Extended component type is untagged,
   -- but its predefined equality operator should incorporate
   -- the user-defined operator of its tagged component type.

end C452001_1;

package body C452001_1 is

   function "=" (Arg1, Arg2 : in TC_Planet) return Boolean is
   begin
      return Arg1.Name = Arg2.Name;
   end "=";

end C452001_1;

package C452001_2 is

   -- Untagged record types
   -- Equality should not be incorporated

   type Spacecraft_Design is (Mariner, Pioneer, Viking, Voyager);
   type Spacecraft is record
     Design      : Spacecraft_Design;
     Operational : Boolean;
   end record;

   function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean;

   type Mission is record
      Craft       : Spacecraft;
      Launch_Date : Natural;
   end record;

   type Inventory is array (Positive range <>) of Spacecraft;

end C452001_2;

package body C452001_2 is

   function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean is
   begin
      return L.Design = R.Design;
   end "=";

end C452001_2;

package C452001_3 is

   type Tagged_Partial_Tagged_Full is tagged private;
   procedure Change (Object : in out Tagged_Partial_Tagged_Full;
                    Value  : in Boolean);

   type Untagged_Partial_Tagged_Full is private;
   procedure Change (Object : in out Untagged_Partial_Tagged_Full;
                    Value  : in Integer);

   type Untagged_Partial_Untagged_Full is private;
   procedure Change (Object : in out Untagged_Partial_Untagged_Full;
                    Value  : in Duration);

private

   type Tagged_Partial_Tagged_Full is
      tagged record
         B : Boolean := True;
         C : Character := ' ';
      end record;
   -- predefined equality checks that all components are equal

   function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean;
   -- primitive equality checks that records equate in component C only

   type Untagged_Partial_Tagged_Full is
      tagged record
         I : Integer := 0;
         P : Positive := 1;
      end record;
   -- predefined equality checks that all components are equal

   function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean;
   -- primitive equality checks that records equate in component P only

   type Untagged_Partial_Untagged_Full is
      record
         D : Duration := 0.0;
         S : String (1..12) := "Ada 9X rules";
      end record;
   -- predefined equality checks that all components are equal

   function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean;
   -- primitive equality checks that records equate in component S only

end C452001_3;
   
with Report;
package body C452001_3 is

   procedure Change (Object : in out Tagged_Partial_Tagged_Full;
                    Value  : in Boolean) is
   begin
      Object := (Report.Ident_Bool(Value), Object.C);
   end Change;

   procedure Change (Object : in out Untagged_Partial_Tagged_Full;
                    Value  : in Integer) is
   begin
      Object := (Report.Ident_Int(Value), Object.P);
   end Change;

   procedure Change (Object : in out Untagged_Partial_Untagged_Full;
                    Value  : in Duration) is
   begin
      Object := (Value, Report.Ident_Str(Object.S));
   end Change;

   function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean is
   begin
      return L.C = R.C;
   end "=";

   function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean is
   begin
      return L.P = R.P;
   end "=";

   function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean is
   begin
      return R.S = L.S;
   end "=";

end C452001_3;


with C452001_0;
with C452001_1;
with C452001_2;
with C452001_3;
with Report;
procedure C452001 is

   Mars_Aphelion : C452001_1.Planet :=
      (Name           => "Mars           ",
       Representation => (Center => (Report.Ident_Int(20),
                                     Report.Ident_Int(0)),
                          Radius => Report.Ident_Int(4),
                          Color  => C452001_0.Red));

   Mars_Perihelion : C452001_1.Planet :=
      (Name           => "Mars           ",
       Representation => (Center => (Report.Ident_Int(-20),
                                     Report.Ident_Int(0)),
                          Radius => Report.Ident_Int(4),
                          Color  => C452001_0.Red));

   -- Mars_Perihelion = Mars_Aphelion if user-defined equality from
   -- the tagged type Colored_Circle was incorporated into
   -- predefined equality for the tagged type Planet. User-defined
   -- equality for Colored_Circle checks only that the Radii are equal.

   Blue_Mars : C452001_1.Planet :=
      (Name           => "Mars           ",
       Representation => (Center => (Report.Ident_Int(10),
                                     Report.Ident_Int(10)),
                          Radius => Report.Ident_Int(4),
                          Color  => C452001_0.Blue));

   -- Blue_Mars should equal Mars_Perihelion, because Names and
   -- Radii are equal (all other components are not).

   Green_Mars : C452001_1.Planet :=
      (Name           => "Mars           ",
       Representation => (Center => (Report.Ident_Int(10),
                                     Report.Ident_Int(10)),
                          Radius => Report.Ident_Int(4),
                          Color  => C452001_0.Green));

   -- Blue_Mars should equal Green_Mars. They differ only in the
   -- Color component. All user-defined equality operations return
   -- True, but records are not equal by predefined equality.

   -- Blue_Mars should equal Mars_Perihelion, because Names and
   -- Radii are equal (all other components are not).

   Moon_Craters : C452001_1.Craters :=
      ((Center => (Report.Ident_Int(9), Report.Ident_Int(11)),
        Radius => Report.Ident_Int(1),