gcc/testsuite/ada/acats/tests/c3/c393a05.a

   1 -- C393A05.A
   2  --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25  --
  26  -- OBJECTIVE:
  27  --      Check that for a nonabstract private extension, any inherited
  28  --      abstract subprograms can be overridden in the private part of
  29  --      the immediately enclosing package and that calls can be made to
  30  --      private dispatching operations.
  31  --
  32  -- TEST DESCRIPTION:
  33  --      This test builds an additional layer upon the foundation code to
  34  --      provide the required "hidden" dispatching operation.  The procedure
  35  --      Swap, a private subprogram, should be called by dispatch.
  36  --
  37  -- TEST FILES:
  38  --      The following files comprise this test:
  39  --
  40  --         F393A00.A   (foundation code)
  41  --         C393A05.A
  42  --
  43  --
  44 -- CHANGE HISTORY:
  45 --      06 Dec 94   SAIC    ACVC 2.0
  46 --
  47  --!
  48
  49  with F393A00_4;
  50  package C393A05_0 is
  51    type Grinder is new F393A00_4.Mill with private;
  52    type Coarseness is (Whole_Bean, Coarse, Medium, Fine, Espresso);
  53
  54    procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness );
  55    function  Grind( It: Grinder ) return Coarseness;
  56
  57    function  Create return Grinder;
  58  private
  59    procedure Swap( A,B: in out Grinder );
  60    type Grinder is new F393A00_4.Mill with
  61      record
  62        Grind : Coarseness := Whole_Bean;
  63      end record;
  64  end C393A05_0;
  65
  66  with F393A00_0;
  67  package body C393A05_0 is
  68    procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness ) is
  69    begin
  70      F393A00_0.TC_Touch( 'A' );
  71      It.Grind := The_Grind;
  72    end Set_Grind;
  73
  74    function  Grind( It: Grinder ) return Coarseness is
  75    begin
  76      F393A00_0.TC_Touch( 'B' );
  77      return It.Grind;
  78    end Grind;
  79
  80    procedure Swap( A,B: in out Grinder ) is
  81      T : constant Grinder := A;
  82    begin
  83      F393A00_0.TC_Touch( 'C' );
  84      A := B;
  85      B := T;
  86    end Swap;
  87
  88    function  Create return Grinder is
  89      One: Grinder;
  90    begin
  91      F393A00_0.TC_Touch( 'D' );
  92      F393A00_4.Initialize( F393A00_4.Mill( One ) );
  93      One.Grind := Fine;
  94      return One;
  95    end Create;
  96  end C393A05_0;
  97
  98  with Report;
  99  with F393A00_0;
 100  with C393A05_0;
 101  procedure C393A05 is
 102
 103    package Tracer renames F393A00_0;
 104    package Coffee renames C393A05_0;
 105    use type Coffee.Coarseness;
 106
 107    Morning   : Coffee.Grinder;
 108    Afternoon : Coffee.Grinder;
 109
 110    Gritty    : Coffee.Coarseness;
 111
 112    procedure Class_Swap( A, B: in out Coffee.Grinder'Class ) is
 113    begin
 114      Coffee.Swap( A, B ); -- dispatch
 115    end Class_Swap;
 116
 117  begin  -- Main test procedure.
 118
 119    Report.Test ("C393A05",  "Check that nonabstract private extensions, "
 120                           & "inherited abstract subprograms overridden "
 121                           & "in the private part can be dispatched from "
 122                           & "outside the package" );
 123
 124    Tracer.TC_Validate( "hh", "Declarations" );
 125
 126    Morning := Coffee.Create;
 127    Tracer.TC_Validate( "hDa", "Creating Morning Coffee" );
 128    Gritty  := Coffee.Grind( Morning );
 129    Tracer.TC_Validate( "B", "Finding Morning Grind" );
 130
 131    Afternoon := Coffee.Create;
 132    Tracer.TC_Validate( "hDa", "Creating Afternoon Coffee" );
 133    Coffee.Set_Grind( Afternoon, Coffee.Medium );
 134    Tracer.TC_Validate( "A", "Setting Afternoon Grind" );
 135
 136    Coffee.Swap( Morning, Afternoon );
 137    Tracer.TC_Validate( "C", "Dispatching Swapping Coffees" );
 138
 139    if Gritty /= Coffee.Grind( Afternoon )
 140       or Coffee.Grind ( Afternoon ) /= Coffee.Fine then
 141      Report.Failed ("Result of Swap");
 142    end if;
 143    Tracer.TC_Validate( "BB", "Finding Afternoon Grind" );
 144
 145    Sunset: declare
 146      Evening   : Coffee.Grinder'Class := Coffee.Create;
 147    begin
 148      Tracer.TC_Validate( "hDa", "Creating Evening Coffee" );
 149
 150      Coffee.Set_Grind( Evening, Coffee.Espresso );
 151      Tracer.TC_Validate( "A", "Setting Evening Grind" );
 152
 153      Morning := Coffee.Grinder( Evening );
 154      Class_Swap( Morning, Evening );
 155      Tracer.TC_Validate( "C", "Swapping Coffees" );
 156      if Coffee.Grind( Morning ) /= Coffee.Espresso then
 157        Report.Failed ("Result of Assignment");
 158      end if;
 159    end Sunset;
 160
 161    Report.Result;
 162
 163  end C393A05;
 164
 165
 166