cc50001.a

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

-- CC50001.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 predefined
--      operator of a formal tagged private type declares a view of the
--      corresponding predefined operator of the actual type (even if the
--      operator has been overridden for the actual type). Check that the
--      body executed is determined by the type and tag of the operands.
--
-- TEST DESCRIPTION:
--      The formal tagged private type has an unknown discriminant part, and
--      is thus indefinite. This allows both definite and indefinite types
--      to be passed as actuals. For tagged types, definite implies
--      nondiscriminated, and indefinite implies discriminated (with known
--      or unknown discriminants).
--
--      Only nonlimited tagged types are tested, since equality operators
--      are not predefined for limited types. 
--
--      A tagged type is passed as an actual to a generic formal tagged
--      private type. The tagged type overrides the predefined equality
--      operator. A subprogram within the generic calls the equality operator
--      of the formal type. In an instance, the equality operator denotes
--      a view of the predefined operator of the actual type, but the
--      call dispatches to the body of the overriding operator.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      21 Nov 95   SAIC    ACVC 2.0.1 fixes: Corrected expected result on
--                          calls to "=" within the instance. Modified
--                          commentary.
--
--!

package CC50001_0 is

   type Count_Type is tagged record                     -- Nondiscriminated
      Count : Integer := 0;                             -- tagged type.
   end record;

   function "="(Left, Right : Count_Type)               -- User-defined
     return Boolean;                                    -- equality operator.


   subtype Str_Len is Natural range 0 .. 100;
   subtype Stu_ID  is String (1 .. 5);
   subtype Dept_ID is String (1 .. 4);
   subtype Emp_ID  is String (1 .. 9);
   type    Status   is (Student, Faculty, Staff);

   type Person_Type (Stat : Status;                     -- Discriminated
                     NameLen, AddrLen : Str_Len) is     -- tagged type.
     tagged record                                 
      Name    : String (1 .. NameLen);
      Address : String (1 .. AddrLen);
      case Stat is
         when Student =>
            Student_ID  : Stu_ID;
         when Faculty =>
            Department  : Dept_ID;
         when Staff   =>
            Employee_ID : Emp_ID;
      end case;
   end record;

   function "="(Left, Right : Person_Type)              -- User-defined
     return Boolean;                                    -- equality operator.


   -- Testing entities: ------------------------------------------------

   TC_Count_Item     : constant Count_Type  := (Count => 111);

   TC_Person_Item    : constant Person_Type :=
     (Faculty, 18, 17, "Eccles, John Scott", "Popham House, Lee", "0931");

   ---------------------------------------------------------------------


end CC50001_0;


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


package body CC50001_0 is

   function "="(Left, Right : Count_Type) return Boolean is
   begin
      return False;   -- Return FALSE even if Left = Right.
   end "=";


   function "="(Left, Right : Person_Type) return Boolean is
   begin
      return False;   -- Return FALSE even if Left = Right.
   end "=";

end CC50001_0;


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


with CC50001_0;  -- Tagged (actual) type declarations.
generic        -- Generic stack abstraction.

   type Item (<>) is tagged private;            -- Formal tagged private type.

package CC50001_1 is

   -- Simulate a generic stack abstraction. In a real application, the
   -- second operand of Push might be of type Stack, and type Stack
   -- would have at least one component (pointing to the top stack item).

   type Stack is private;

   procedure Push (I : in Item; TC_Check : out Boolean);

   -- ... Other stack operations.

private

   -- ... Stack and ancillary type declarations.

   type Stack is record                       -- Artificial.
      null;
   end record;

end CC50001_1;


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


package body CC50001_1 is

   -- For the sake of brevity, the implementation of Push is completely
   -- artificial; the goal is to model a call of the equality operator within
   -- the generic.
   --
   -- A real application might implement Push such that it does not add new
   -- items to the stack if they are identical to the top item; in that
   -- case, the equality operator would be called as part of an "if"
   -- condition.

   procedure Push (I : in Item; TC_Check : out Boolean) is
   begin
      TC_Check := not (I = I);              -- Call user-defined "="; should
                                            -- return FALSE. Negation of
                                            -- result makes TC_Check TRUE.
   end Push;

end CC50001_1;


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


with CC50001_0;  -- Tagged (actual) type declarations.
with CC50001_1;  -- Generic stack abstraction.

use  CC50001_0;  -- Overloaded "=" directly visible.

with Report;
procedure CC50001 is

   package Count_Stacks  is new CC50001_1 (CC50001_0.Count_Type);
   package Person_Stacks is new CC50001_1 (CC50001_0.Person_Type);

   User_Defined_Op_Called : Boolean;

begin
   Report.Test ("CC50001", "Check that, in an instance, each implicit "     &
                "declaration of a primitive subprogram of a formal tagged " &
                "private type declares a view of the corresponding "        &
                "predefined operator of the actual type (even if the "      &
                "operator has been overridden or hidden for the actual type)");

--
-- Test which "=" is called inside generic:
--

   User_Defined_Op_Called := False;

   Count_Stacks.Push (CC50001_0.TC_Count_Item,
                      User_Defined_Op_Called);


   if not User_Defined_Op_Called then
      Report.Failed ("User-defined ""="" not called inside generic for Count");
   end if;


   User_Defined_Op_Called := False;

   Person_Stacks.Push (CC50001_0.TC_Person_Item,
                       User_Defined_Op_Called);

   if not User_Defined_Op_Called then
      Report.Failed ("User-defined ""="" not called inside generic " &
                     "for Person");
   end if;


--
-- Test which "=" is called outside generic:
--

   User_Defined_Op_Called := False;

   User_Defined_Op_Called :=
     not (CC50001_0.TC_Count_Item = CC50001_0.TC_Count_Item);

   if not User_Defined_Op_Called then
      Report.Failed ("User-defined ""="" not called outside generic "&
                     "for Count");
   end if;


   User_Defined_Op_Called := False;

   User_Defined_Op_Called :=
     not (CC50001_0.TC_Person_Item = CC50001_0.TC_Person_Item);

   if not User_Defined_Op_Called then
      Report.Failed ("User-defined ""="" not called outside generic "&
                     "for Person");
   end if;


   Report.Result;
end CC50001;