cc51a01.a

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

-- CC51A01.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, in an instance, each implicit declaration of a user-defined
--      subprogram of a formal derived record type declares a view of the
--      corresponding primitive subprogram of the ancestor, even if the
--      primitive subprogram has been overridden for the actual type.
--
-- TEST DESCRIPTION:
--      Declare a "fraction" type abstraction in a package (foundation code).
--      Declare a "fraction" I/O routine in a generic package with a formal
--      derived type whose ancestor type is the fraction type declared in
--      the first package. Within the I/O routine, call other operations of
--      ancestor type. Derive from the root fraction type in another package
--      and override one of the operations called in the generic I/O routine.
--      Derive from the derivative of the root fraction type. Instantiate
--      the generic package for each of the three types and call the I/O
--      routine.
--
-- TEST FILES:
--      The following files comprise this test:
--
--         FC51A00.A
--         CC51A01.A
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!

with FC51A00;         -- Fraction type abstraction.
generic               -- Fraction I/O support.
   type Fraction is new FC51A00.Fraction_Type;     -- Formal derived type of a
package CC51A01_0 is                               -- (private) record type.

   -- Simulate writing a fraction to standard output. In a real application,
   -- this subprogram might be a procedure which uses Text_IO routines. For
   -- the purposes of the test, the "output" is returned to the caller as a
   -- string.
   function Put (Item : in Fraction) return String;

   -- ... Other I/O operations for fractions.

end CC51A01_0;


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


package body CC51A01_0 is

   function Put (Item : in Fraction) return String is
      Num : constant String :=              -- Fraction's primitive subprograms
        Integer'Image (Numerator (Item));   -- are inherited from its parent
      Den : constant String :=              -- (FC51A00.Fraction_Type) and NOT
        Integer'Image (Denominator (Item)); -- from the actual type.
   begin
      return (Num & '/' & Den);
   end Put;

end CC51A01_0;


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


with FC51A00;         -- Fraction type abstraction.
package CC51A01_1 is

   -- Derive directly from the root type of the class and override one of the
   -- primitive subprograms.

   type Pos_Fraction is new FC51A00.Fraction_Type;     -- Derived directly from
                                                       -- root type of class.
   -- Inherits "/" from root type.
   -- Inherits "-" from root type.
   -- Inherits Numerator from root type.
   -- Inherits Denominator from root type.

   -- Return absolute value of numerator as integer.
   function Numerator (Frac : Pos_Fraction)            -- Overrides parent's
     return Integer;                                   -- operation.

end CC51A01_1;


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


package body CC51A01_1 is

   -- This body should never be called.
   --
   -- The test sends the function Numerator a fraction with a negative
   -- numerator, and expects this negative numerator to be returned. This
   -- version of the function returns the absolute value of the numerator.
   -- Thus, a call to this version is detectable by examining the sign
   -- of the return value.

   function Numerator (Frac : Pos_Fraction) return Integer is
      Converted_Frac : FC51A00.Fraction_Type := FC51A00.Fraction_Type (Frac);
      Orig_Numerator : Integer := FC51A00.Numerator (Converted_Frac);
   begin
      return abs (Orig_Numerator);
   end Numerator;

end CC51A01_1;


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


with FC51A00;     -- Fraction type abstraction.
with CC51A01_0;   -- Fraction I/O support.
with CC51A01_1;   -- Positive fraction type abstraction.

with Report;
procedure CC51A01 is

   type Distance is new CC51A01_1.Pos_Fraction;    -- Derived indirectly from
                                                   -- root type of class.
   -- Inherits "/" indirectly from root type.
   -- Inherits "-" indirectly from root type.
   -- Inherits Numerator directly from parent type.
   -- Inherits Denominator indirectly from root type.

   use FC51A00, CC51A01_1;                         -- All primitive subprograms
                                                   -- directly visible.

   package Fraction_IO     is new CC51A01_0 (Fraction_Type);
   package Pos_Fraction_IO is new CC51A01_0 (Pos_Fraction);
   package Distance_IO     is new CC51A01_0 (Distance);

   -- For each of the instances above, the subprogram "Put" should produce
   -- the same result. That is, the primitive subprograms called by Put
   -- should in all cases be those of the type Fraction_Type, which is the
   -- ancestor type for the formal derived type in the generic unit. In
   -- particular, for Pos_Fraction_IO and Distance_IO, the versions of
   -- Numerator called should NOT be those of the actual types, which override
   -- Fraction_Type's version.

   TC_Expected_Result : constant String := "-3/ 16";

   TC_Root_Type_Of_Class  : Fraction_Type := -3/16;
   TC_Direct_Derivative   : Pos_Fraction  := -3/16;
   TC_Indirect_Derivative : Distance      := -3/16;

begin
   Report.Test ("CC51A01", "Check that, in an instance, each implicit "     &
                "declaration of a user-defined subprogram of a formal "     &
                "derived record type declares a view of the corresponding " &
                "primitive subprogram of the ancestor, even if the "        &
                "primitive subprogram has been overridden for the actual "  &
                "type");

   if (Fraction_IO.Put (TC_Root_Type_Of_Class) /= TC_Expected_Result) then
      Report.Failed ("Wrong result for root type");
   end if;

   if (Pos_Fraction_IO.Put (TC_Direct_Derivative) /= TC_Expected_Result) then
      Report.Failed ("Wrong result for direct derivative");
   end if;

   if (Distance_IO.Put (TC_Indirect_Derivative) /= TC_Expected_Result) then
      Report.Failed ("Wrong result for INdirect derivative");
   end if;

   Report.Result;
end CC51A01;