cc51002.a

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

-- CC51002.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, for formal derived tagged types, the formal parameter
--      names and default expressions for a primitive subprogram in an
--      instance are determined by the primitive subprogram of the ancestor
--      type, but that the primitive subprogram body executed is that of the
--      actual type.
--
-- TEST DESCRIPTION:
--      Define a root tagged type in a library-level package and give it a
--      primitive subprogram. Provide a default expression for a non-tagged
--      parameter of the subprogram. Declare a library-level generic subprogram
--      with a formal derived type using the root type as ancestor. Call
--      the primitive subprogram of the root type using named association for
--      the tagged parameter, and provide no actual for the defaulted
--      parameter. Extend the root type in a second package and override the
--      root type's subprogram with one which has different parameter names
--      and no default expression for the non-tagged parameter. Instantiate
--      the generic subprogram for each of the tagged types in the class and
--      call the instances.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!

package CC51002_0 is  -- Root message type and operations.

   type Recipients is (None, Root, Sysop, Local, Remote);

   type Msg_Type is tagged record                             -- Root type of
      Text : String (1 .. 10);                                -- class.
   end record;

   function Send (Msg : in Msg_Type;                          -- Primitive
                  To  : Recipients := Local) return Boolean;  -- subprogram.

   -- ...Other message operations.

end CC51002_0;


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


package body CC51002_0 is

   -- The implementation of Send is purely artificial; the validity of
   -- its implementation in the context of the abstraction is irrelevant to
   -- the feature being tested.

   function Send (Msg : in Msg_Type;
                  To  : Recipients := Local) return Boolean is
   begin
      return (Msg.Text = "Greetings!" and To = Local);
   end Send;

end CC51002_0;


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


with CC51002_0;  -- Root message type and operations.
generic          -- Message class function.
   type Msg_Block is new CC51002_0.Msg_Type with private;
function CC51002_1 (M : in Msg_Block) return Boolean;


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


function CC51002_1 (M : in Msg_Block) return Boolean is
   Okay : Boolean := False;
begin

   -- The call to Send below uses the ancestor type's parameter name, which
   -- should be legal even if the actual subprogram called does not have a
   -- parameter of that name. Furthermore, it uses the ancestor type's default
   -- expression for the second parameter, which should be legal even if the
   -- the actual subprogram called has no such default expression.

   Okay := Send (Msg => M);
   -- ...Other processing.
   return Okay;

end CC51002_1;


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


with CC51002_0;       -- Root message type and operations.
package CC51002_2 is  -- Extended message type and operations.

   type Sender_Type is (Inside, Outside);

   type Who_Msg_Type is new CC51002_0.Msg_Type with record   -- Derivative of
      From : Sender_Type;                                    -- root type of
   end record;                                               -- class.


   -- Note: this overriding version of Send has different parameter names
   -- from the root type's function. It also has no default expression.

   function Send (M : Who_Msg_Type;                          -- Overrides
                  R : CC51002_0.Recipients) return Boolean;  -- root type's
                                                             -- operation.
   -- ...Other extended message operations.

end CC51002_2;


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


package body CC51002_2 is

   -- The implementation of Send is purely artificial; the validity of
   -- its implementation in the context of the abstraction is irrelevant to
   -- the feature being tested.

   function Send (M : Who_Msg_Type; R : CC51002_0.Recipients) return Boolean is
      use type CC51002_0.Recipients;
   begin
      return (M.Text = "Willkommen"     and
              M.From = Outside          and
              R      = CC51002_0.Local);
   end Send;

end CC51002_2;


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


with CC51002_0;  -- Root message type and operations.
with CC51002_1;  -- Message class function.
with CC51002_2;  -- Extended message type and operations.

with Report;
procedure CC51002 is

   function Send_Msg  is new CC51002_1 (CC51002_0.Msg_Type);
   function Send_WMsg is new CC51002_1 (CC51002_2.Who_Msg_Type);

   Mess  : CC51002_0.Msg_Type     := (Text => "Greetings!");
   WMess : CC51002_2.Who_Msg_Type := (Text => "Willkommen",
                                      From => CC51002_2.Outside);

   TC_Okay_MStatus  : Boolean := False;
   TC_Okay_WMStatus : Boolean := False;

begin
   Report.Test ("CC51002", "Check that, for formal derived tagged types, " &
                "the formal parameter names and default expressions for "  &
                "a primitive subprogram in an instance are determined by " &
                "the primitive subprogram of the ancestor type, but that " &
                "the primitive subprogram body executed is that of the"    &
                "actual type");

   TC_Okay_MStatus := Send_Msg (Mess);
   if not TC_Okay_MStatus then
      Report.Failed ("Wrong result from call to root type's operation");
   end if;

   TC_Okay_WMStatus := Send_WMsg (WMess);
   if not TC_Okay_WMStatus then
      Report.Failed ("Wrong result from call to derived type's operation");
   end if;

   Report.Result;
end CC51002;