Subversion Repositories openrisc

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