cc51006.a

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

-- CC51006.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 primitive
--      subprogram of a formal (nontagged) derived type declares a view of
--      the corresponding primitive subprogram of the ancestor type, even if
--      the subprogram has been overridden for the actual type. Check that for
--      a formal derived type with no discriminant part, if the ancestor
--      subtype is an unconstrained scalar subtype then the actual may be
--      either constrained or unconstrained.
--
-- TEST DESCRIPTION:
--      The formal derived type has no discriminant part, but the ancestor
--      subtype is unconstrained, making the formal type unconstrained. Since
--      the ancestor subtype is a scalar subtype (not an access or composite
--      subtype), the actual may be either constrained or unconstrained.
--
--      Declare a root type of a class as an unconstrained scalar (use floating
--      point). Declare a primitive subprogram of the root type. Declare a
--      generic package which has a formal derived type with the scalar root
--      type as ancestor. Inside the generic, declare an operation which calls
--      the ancestor type's primitive subprogram. Derive both constrained and
--      unconstrained types from the root type and override the primitive
--      subprogram for each. Declare a constrained subtype of the unconstrained
--      derivative. Instantiate the generic package for the derived types and
--      the subtype and call the "generic" operation for each one. Confirm that
--      in all cases the root type's implementation of the primitive
--      subprogram is called.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!

package CC51006_0 is  -- Weight class.

   type Weight_Type is digits 3;         -- Root type of class (unconstrained).

   function Weight_To_String (Wt : Weight_Type) return String;

   -- ... Other operations.

end CC51006_0;


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


package body CC51006_0 is

   -- The implementations of the operations below are purely artificial; the
   -- validity of their implementations in the context of the abstraction is
   -- irrelevant to the feature being tested.

   function Weight_To_String (Wt : Weight_Type) return String is
   begin
      if Wt > 0.0 then         -- Always true for this test.
         return ("Root type's implementation called");
      else
         return ("Unexpected result                ");
      end if;
   end Weight_To_String;

end CC51006_0;


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


with CC51006_0;  -- Weight class.
generic          -- Generic weight operations. 
   type Weight is new CC51006_0.Weight_Type;
package CC51006_1 is

   procedure Output_Weight (Wt : in Weight; TC_Return : out String);

   -- ... Other operations.

end CC51006_1;


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


package body CC51006_1 is


   -- The implementation of this procedure is purely artificial, and contains
   -- an artificial parameter for testing purposes: the procedure returns the
   -- weight string to the caller.

   procedure Output_Weight (Wt : in Weight; TC_Return : out String) is
   begin
      TC_Return := Weight_To_String (Wt);   -- Should always call root type's
   end Output_Weight;                       -- implementation.


end CC51006_1;


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


with CC51006_0;       -- Weight class.
use  CC51006_0;
package CC51006_2 is  -- Extensions to weight class.

   type Grams is new Weight_Type;                         -- Unconstrained
                                                          -- derivative.

   function Weight_To_String (Wt : Grams) return String;  -- Overrides root
                                                          -- type's operation.

   subtype Milligrams is Grams                            -- Constrained
     range 0.0 .. 0.999;                                  -- subtype (of der.).

   type Pounds is new Weight_Type                         -- Constrained
     range 0.0 .. 500.0;                                  -- derivative.

   function Weight_To_String (Wt : Pounds) return String; -- Overrides root
                                                          -- type's operation.

end CC51006_2;


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


package body CC51006_2 is

   -- The implementations of the operations below are purely artificial; the
   -- validity of their implementations in the context of the abstraction is
   -- irrelevant to the feature being tested.

   function Weight_To_String (Wt : Grams) return String is
   begin
      return ("GRAMS: Should never be called    ");
   end Weight_To_String;


   function Weight_To_String (Wt : Pounds) return String is
   begin
      return ("POUNDS: Should never be called   ");
   end Weight_To_String;

end CC51006_2;


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


with CC51006_1; -- Generic weight operations.
with CC51006_2; -- Extensions to weight class.

with Report;
procedure CC51006 is

   package Metric_Wts_G  is new CC51006_1 (CC51006_2.Grams);      -- Unconstr.
   package Metric_Wts_MG is new CC51006_1 (CC51006_2.Milligrams); -- Constr.
   package US_Wts        is new CC51006_1 (CC51006_2.Pounds);     -- Constr.

   Gms : CC51006_2.Grams      := 113.451;
   Mgm : CC51006_2.Milligrams := 0.549;
   Lbs : CC51006_2.Pounds     := 24.52;


   subtype TC_Buffers is String (1 .. 33);

   TC_Expected : constant TC_Buffers := "Root type's implementation called";
   TC_Buffer   :          TC_Buffers;

begin
   Report.Test ("CC51006", "Check that, in an instance, each implicit "  &
                "declaration of a primitive subprogram of a formal "     &
                "(nontagged) type declares a view of the corresponding " &
                "primitive subprogram of the ancestor type");


   Metric_Wts_G.Output_Weight (Gms, TC_Buffer);

   if TC_Buffer /= TC_Expected then
      Report.Failed ("Root operation not called for unconstrained derivative");
   end if;


   Metric_Wts_MG.Output_Weight (Mgm, TC_Buffer);

   if TC_Buffer /= TC_Expected then
      Report.Failed ("Root operation not called for constrained subtype");
   end if;


   US_Wts.Output_Weight (Lbs, TC_Buffer);

   if TC_Buffer /= TC_Expected then
      Report.Failed ("Root operation not called for constrained derivative");
   end if;

   Report.Result;
end CC51006;