c393a03.a

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

-- C393A03.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 non-abstract primitive subprogram of an abstract
--      type can be called as a dispatching operation and that the body
--      of this subprogram can make a dispatching call to an abstract
--      operation of the corresponding abstract type. 
--
-- TEST DESCRIPTION:
--      This test expands on the class family defined in foundation F393A00
--      by deriving a new abstract type from the root abstract type "Object".
--      The subprograms defined for the new abstract type are then
--      appropriately overridden, and the test ultimately calls various
--      mixtures of these subprograms to check that the dispatching occurs
--      correctly.
--
-- TEST FILES:
--      The following files comprise this test:
--
--         F393A00.A   (foundation code)
--         C393A03.A
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      19 Dec 94   SAIC    Removed ARM references from objective text.
--      23 Oct 95   SAIC    Fixed bugs for ACVC 2.0.1
--
--!

------------------------------------------------------------------- C393A03_0

with F393A00_1;
package C393A03_0 is

  type Counting_Object is abstract new F393A00_1.Object with private;
  -- inherits Initialize, Swap (abstract) and Create (abstract)

  procedure Bump ( A_Counter: in out Counting_Object );
  procedure Clear( A_Counter: in out Counting_Object ) is abstract;
  procedure Zero ( A_Counter: in out Counting_Object );
  function  Value( A_Counter: Counting_Object'Class ) return Natural;

private

  type Counting_Object is abstract new F393A00_1.Object with
    record
      Tally : Natural :=0;
    end record;

end C393A03_0;

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

with F393A00_0;
package body C393A03_0 is

  procedure Bump ( A_Counter: in out Counting_Object ) is
  begin
    F393A00_0.TC_Touch('A');
    A_Counter.Tally := A_Counter.Tally +1;
  end Bump;

  procedure Zero ( A_Counter: in out Counting_Object ) is
  begin
    F393A00_0.TC_Touch('B');

 -- dispatching call to abstract operation of Counting_Object
    Clear( Counting_Object'Class(A_Counter) );

    A_Counter.Tally := 0;

  end Zero;

  function  Value( A_Counter: Counting_Object'Class ) return Natural is
  begin
    F393A00_0.TC_Touch('C');
    return A_Counter.Tally;
  end Value;

end C393A03_0;

------------------------------------------------------------------- C393A03_1

with C393A03_0;
package C393A03_1 is

  type Modular_Object is new C393A03_0.Counting_Object with private;
  -- inherits Initialize, Bump, Zero and Value,
  -- inherits abstract Swap, Create and Clear

  procedure Swap( A,B: in out Modular_Object );
  procedure Clear( It: in out Modular_Object );
  procedure Set_Max( It : in out Modular_Object; Value : Natural );
  function  Create return Modular_Object;

private

  type Modular_Object is new C393A03_0.Counting_Object with
    record
      Max_Value : Natural;
    end record;

end C393A03_1;

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

with F393A00_0;
package body C393A03_1 is

  procedure Swap( A,B: in out Modular_Object ) is
    T : constant Modular_Object := B;
  begin
    F393A00_0.TC_Touch('1');
    B := A;
    A := T;
  end Swap;

  procedure Clear( It: in out Modular_Object ) is
  begin
    F393A00_0.TC_Touch('2');
    null;
  end Clear;

  procedure Set_Max( It : in out Modular_Object; Value : Natural ) is
  begin
    F393A00_0.TC_Touch('3');
    It.Max_Value := Value;
  end Set_Max;

  function  Create return Modular_Object is
    AMO : Modular_Object;
  begin
    F393A00_0.TC_Touch('4');
    AMO.Max_Value := Natural'Last;
    return AMO;
  end Create;

end C393A03_1;

--------------------------------------------------------------------- C393A03

with Report;
with F393A00_0;
with F393A00_1;
with C393A03_0;
with C393A03_1;
procedure C393A03 is

  A_Thing       : C393A03_1.Modular_Object;
  Another_Thing : C393A03_1.Modular_Object;

  procedure Initialize( It: in out C393A03_0.Counting_Object'Class ) is
  begin
    C393A03_0.Initialize( It );  -- dispatch to inherited procedure
  end Initialize;

  procedure Bump( It: in out C393A03_0.Counting_Object'Class ) is
  begin
    C393A03_0.Bump( It ); -- dispatch to non-abstract procedure
  end Bump;

  procedure Set_Max( It  : in out C393A03_1.Modular_Object'Class;
                     Val : Natural) is
  begin
    C393A03_1.Set_Max( It, Val ); -- dispatch to non-abstract procedure
  end Set_Max;

  procedure Swap( A, B  : in out C393A03_0.Counting_Object'Class ) is
  begin
    C393A03_0.Swap( A, B ); -- dispatch to inherited abstract procedure
  end Swap;

  procedure Zero( It: in out C393A03_0.Counting_Object'Class ) is
  begin
    C393A03_0.Zero( It ); -- dispatch to non-abstract procedure
  end Zero;

begin  -- Main test procedure.

   Report.Test ("C393A03", "Check that a non-abstract primitive subprogram "
			 & "of an abstract type can be called as a "
			 & "dispatching operation and that the body of this "
			 & "subprogram can make a dispatching call to an "
			 & "abstract operation of the corresponding "
			 & "abstract type" );

   A_Thing := C393A03_1.Create; -- Max_Value = Natural'Last
   F393A00_0.TC_Validate( "4", "Overridden primitive layer 2");

   Initialize( A_Thing );
   Initialize( Another_Thing );
   F393A00_0.TC_Validate( "aa", "Non-abstract primitive layer 0");
   
   Bump( A_Thing ); -- Tally = 1
   F393A00_0.TC_Validate( "A", "Non-abstract primitive layer 1");

   Set_Max( A_Thing, 42 ); -- Max_Value = 42
   F393A00_0.TC_Validate( "3", "Non-abstract normal layer 2");

   if not F393A00_1.Initialized( A_Thing ) then
     Report.Failed("Initialize didn't");
   end if;
   F393A00_0.TC_Validate( "b", "Class-wide layer 0");

   Swap( A_Thing, Another_Thing );
   F393A00_0.TC_Validate( "1", "Overridden abstract layer 2");

   Zero( A_Thing );
   F393A00_0.TC_Validate( "B2", "Non-abstract layer 0, calls dispatch");

   if C393A03_0.Value( A_Thing ) /= 0 then
     Report.Failed("Zero didn't");
   end if;
   F393A00_0.TC_Validate( "C", "Class-wide normal layer 2");

   Report.Result;

end C393A03;