Subversion Repositories openrisc_me

-- C393A05.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 a nonabstract private extension, any inherited

 --      abstract subprograms can be overridden in the private part of

 --      the immediately enclosing package and that calls can be made to

 --      private dispatching operations.

 --

 -- TEST DESCRIPTION:

 --      This test builds an additional layer upon the foundation code to

 --      provide the required "hidden" dispatching operation.  The procedure

 --      Swap, a private subprogram, should be called by dispatch.

 --

 -- TEST FILES:

 --      The following files comprise this test:

 --

 --         F393A00.A   (foundation code)

 --         C393A05.A

 --

 --

-- CHANGE HISTORY:

--      06 Dec 94   SAIC    ACVC 2.0

--

 --!

 with F393A00_4;

 package C393A05_0 is

   type Grinder is new F393A00_4.Mill with private;

   type Coarseness is (Whole_Bean, Coarse, Medium, Fine, Espresso);

   procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness );

   function  Grind( It: Grinder ) return Coarseness;

   function  Create return Grinder;

 private

   procedure Swap( A,B: in out Grinder );

   type Grinder is new F393A00_4.Mill with

     record

       Grind : Coarseness := Whole_Bean;

     end record;

 end C393A05_0;

 with F393A00_0;

 package body C393A05_0 is

   procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness ) is

   begin

     F393A00_0.TC_Touch( 'A' );

     It.Grind := The_Grind;

   end Set_Grind;

   function  Grind( It: Grinder ) return Coarseness is

   begin

     F393A00_0.TC_Touch( 'B' );

     return It.Grind;

   end Grind;

   procedure Swap( A,B: in out Grinder ) is

     T : constant Grinder := A;

   begin

     F393A00_0.TC_Touch( 'C' );

     A := B;

     B := T;

   end Swap;

   function  Create return Grinder is

     One: Grinder;

   begin

     F393A00_0.TC_Touch( 'D' );

     F393A00_4.Initialize( F393A00_4.Mill( One ) );

     One.Grind := Fine;

     return One;

   end Create;

 end C393A05_0;

 with Report;

 with F393A00_0;

 with C393A05_0;

 procedure C393A05 is

   package Tracer renames F393A00_0;

   package Coffee renames C393A05_0;

   use type Coffee.Coarseness;

   Morning   : Coffee.Grinder;

   Afternoon : Coffee.Grinder;

   Gritty    : Coffee.Coarseness;

   procedure Class_Swap( A, B: in out Coffee.Grinder'Class ) is

   begin

     Coffee.Swap( A, B ); -- dispatch

   end Class_Swap;

 begin  -- Main test procedure.

   Report.Test ("C393A05",  "Check that nonabstract private extensions, "

                          & "inherited abstract subprograms overridden "

                          & "in the private part can be dispatched from "

                          & "outside the package" );

   Tracer.TC_Validate( "hh", "Declarations" );

   Morning := Coffee.Create;

   Tracer.TC_Validate( "hDa", "Creating Morning Coffee" );

   Gritty  := Coffee.Grind( Morning );

   Tracer.TC_Validate( "B", "Finding Morning Grind" );

   Afternoon := Coffee.Create;

   Tracer.TC_Validate( "hDa", "Creating Afternoon Coffee" );

   Coffee.Set_Grind( Afternoon, Coffee.Medium );

   Tracer.TC_Validate( "A", "Setting Afternoon Grind" );

   Coffee.Swap( Morning, Afternoon );

   Tracer.TC_Validate( "C", "Dispatching Swapping Coffees" );

   if Gritty /= Coffee.Grind( Afternoon )

      or Coffee.Grind ( Afternoon ) /= Coffee.Fine then

     Report.Failed ("Result of Swap");

   end if;

   Tracer.TC_Validate( "BB", "Finding Afternoon Grind" );

   Sunset: declare

     Evening   : Coffee.Grinder'Class := Coffee.Create;

   begin

     Tracer.TC_Validate( "hDa", "Creating Evening Coffee" );

     Coffee.Set_Grind( Evening, Coffee.Espresso );

     Tracer.TC_Validate( "A", "Setting Evening Grind" );

     Morning := Coffee.Grinder( Evening );

     Class_Swap( Morning, Evening );

     Tracer.TC_Validate( "C", "Swapping Coffees" );

     if Coffee.Grind( Morning ) /= Coffee.Espresso then

       Report.Failed ("Result of Assignment");

     end if;

   end Sunset;

   Report.Result;

 end C393A05;