Subversion Repositories openrisc_me

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