cc51001.a

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

-- CC51001.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 a formal parameter of a generic package may be a formal
--      derived type. Check that the formal derived type may have an unknown
--      discriminant part. Check that the ancestor type in a formal derived
--      type definition may be a tagged type, and that the actual parameter
--      may be a descendant of the ancestor type. Check that the formal derived
--      type belongs to the derivation class rooted at the ancestor type;
--      specifically, that components of the ancestor type may be referenced
--      within the generic. Check that if a formal derived subtype is
--      indefinite then the actual may be either definite or indefinite.
--
-- TEST DESCRIPTION:
--      Define a class of tagged types with a definite root type. Extend the
--      root type with a discriminated component. Since discriminants of
--      tagged types may not have defaults, the type is indefinite.
--
--      Extend the extension with a second discriminated component, but with
--      a new discriminant part. Declare a generic package with a formal
--      derived type using the root type of the class as ancestor, and an
--      unknown discriminant part. Declare an operation in the generic which
--      accesses the common component of types in the class.
--
--      In the main program, instantiate the generic with each type in the
--      class and verify that the operation correctly accesses the common
--      component.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!

package CC51001_0 is  -- Root type for message class.

   subtype Msg_String is String (1 .. 20);

   type Msg_Type is tagged record                          -- Root type of
      Text : Msg_String := (others => ' ');                -- class (definite).
   end record;

end CC51001_0;


-- No body for CC51001_0.


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


with CC51001_0;       -- Root type for message class.
package CC51001_1 is  -- Extensions to message class.

   subtype Source_Length is Natural range 0 .. 10;

   type From_Msg_Type (SLen : Source_Length) is            -- Direct derivative
     new CC51001_0.Msg_Type with record                    -- of root type
      From : String (1 .. SLen);                           -- (indefinite).
   end record;

   subtype Dest_Length is Natural range 0 .. 10;



   type To_From_Msg_Type (DLen : Dest_Length) is           -- Indirect
     new From_Msg_Type (SLen => 10) with record            -- derivative of
      To : String (1 .. DLen);                             -- root type
   end record;                                             -- (indefinite).

end CC51001_1;


-- No body for CC51001_1.


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


with CC51001_0;       -- Root type for message class.
generic               -- I/O operations for message class.
   type Message_Type (<>) is new CC51001_0.Msg_Type with private;
package CC51001_2 is

   -- This subprogram contains an artificial result for testing purposes:
   -- the function returns the text of the message to the caller as a string.

   function Print_Message (M : in Message_Type) return String;

   -- ... Other operations.

end CC51001_2;


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


package body CC51001_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 Print_Message (M : in Message_Type) return String is
   begin
      return M.Text;
   end Print_Message;

end CC51001_2;


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


with CC51001_0;  -- Root type for message class.
with CC51001_1;  -- Extensions to message class.
with CC51001_2;  -- I/O operations for message class.

with Report;
procedure CC51001 is

   -- Instantiate for various types in the class:

   package Msgs   is new CC51001_2 (CC51001_0.Msg_Type);         -- Definite.
   package FMsgs  is new CC51001_2 (CC51001_1.From_Msg_Type);    -- Indefinite.
   package TFMsgs is new CC51001_2 (CC51001_1.To_From_Msg_Type); -- Indefinite.



   Msg   : CC51001_0.Msg_Type         := (Text => "This is message #001");
   FMsg  : CC51001_1.From_Msg_Type    := (Text => "This is message #002",
                                          SLen => 2,
                                          From => "Me");
   TFMsg : CC51001_1.To_From_Msg_Type := (Text => "This is message #003",
                                          From => "You       ",
                                          DLen => 4,
                                          To   => "Them");

   Expected_Msg   : constant String := "This is message #001";
   Expected_FMsg  : constant String := "This is message #002";
   Expected_TFMsg : constant String := "This is message #003";

begin
   Report.Test ("CC51001", "Check that the formal derived type may have " &
                "an unknown discriminant part. Check that the ancestor " &
                "type in a formal derived type definition may be a " &
                "tagged type, and that the actual parameter may be any " &
                "definite or indefinite descendant of the ancestor type");

   if (Msgs.Print_Message (Msg) /= Expected_Msg) then
      Report.Failed ("Wrong result for definite root type");
   end if;

   if (FMsgs.Print_Message (FMsg) /= Expected_FMsg) then
      Report.Failed ("Wrong result for direct indefinite derivative");
   end if;

   if (TFMsgs.Print_Message (TFMsg) /= Expected_TFMsg) then
      Report.Failed ("Wrong result for Indirect indefinite derivative");
   end if;

   Report.Result;
end CC51001;