gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c3/c3a0011.a

   1 -- C3A0011.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 an access-to-subprogram object whose type is declared in a
  28 --      parent package, may be used to invoke subprograms in a child package.
  29 --      Check that such access objects may be stored in a data structure and
  30 --      that subprograms may be called by walking the data structure.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      In the package, declare an access to procedure type.  Declare an
  34 --      array of the access type.  Declare three different procedures that
  35 --      can be referred to by the access to procedure type.
  36 --
  37 --      In the visible child package, declare two procedures that can be
  38 --      referred to by the access to procedure type of the parent.  Build
  39 --      the array by calling each procedure indirectly through the access
  40 --      value.
  41 --
  42 --
  43 -- CHANGE HISTORY:
  44 --      06 Dec 94   SAIC    ACVC 2.0
  45 --      16 Dec 94   SAIC    Improved visibility of "/=" in main body
  46 --
  47 --!
  48
  49 package C3A0011_0 is -- Interpreter
  50
  51    type Compass_Point is mod 360;
  52
  53    function Heading return Compass_Point;
  54
  55    -- Type accesses to any procedure
  56    type Action_Ptr is access procedure;
  57
  58    -- Array of access to procedure
  59    type Action_Array is array (Natural range <>) of Action_Ptr;
  60
  61    procedure Rotate_Left;
  62
  63    procedure Rotate_Right;
  64
  65    procedure Center;
  66
  67 private
  68    The_Heading : Compass_Point := Compass_Point'First;
  69
  70 end C3A0011_0;
  71
  72
  73 -----------------------------------------------------------------------------
  74
  75
  76 package body C3A0011_0 is
  77
  78    function Heading return Compass_Point is
  79    begin
  80      return The_Heading;
  81    end Heading;
  82
  83    procedure Rotate_Left is
  84    begin
  85       The_Heading := The_Heading - 90;
  86    end Rotate_Left;
  87
  88
  89    procedure Rotate_Right is
  90    begin
  91       The_Heading := The_Heading + 90;
  92    end Rotate_Right;
  93
  94
  95    procedure Center is
  96    begin
  97       The_Heading := 0;
  98    end Center;
  99
 100 end C3A0011_0;
 101
 102
 103 -----------------------------------------------------------------------------
 104
 105
 106 package C3A0011_0.Action is
 107
 108    procedure Rotate_Front;
 109
 110    procedure Rotate_Back;
 111
 112 end C3A0011_0.Action;
 113
 114
 115 -----------------------------------------------------------------------------
 116
 117
 118 package body C3A0011_0.Action is
 119
 120    procedure Rotate_Front is
 121    begin
 122       The_Heading := The_Heading + 5;
 123    end Rotate_Front;
 124
 125
 126    procedure Rotate_Back is
 127    begin
 128       The_Heading := The_Heading - 5;
 129    end Rotate_Back;
 130
 131 end C3A0011_0.Action;
 132
 133
 134 -----------------------------------------------------------------------------
 135
 136
 137 with C3A0011_0.Action;
 138
 139 with Report;
 140
 141 procedure C3A0011 is
 142
 143    Total_Actions   : constant := 6;
 144
 145    Action_Sequence : C3A0011_0.Action_Array (1 .. Total_Actions);
 146
 147    type Result_Array is array (Natural range <>) of C3A0011_0.Compass_Point;
 148
 149    Action_Results  : Result_Array(1 .. Total_Actions);
 150
 151    package IA renames C3A0011_0.Action;
 152
 153 begin
 154
 155    Report.Test ("C3A0011", "Check that an access-to-subprogram object whose "
 156                          & "type is declared in a parent package, may be "
 157                          & "used to invoke subprograms in a child package. "
 158                          & "Check that such access objects may be stored in "
 159                          & "a data structure and that subprograms may be "
 160                          & "called by walking the data structure");
 161
 162    -- Build the action sequence
 163    Action_Sequence := (C3A0011_0.Rotate_Left'Access,
 164                        C3A0011_0.Center'Access,
 165                        C3A0011_0.Rotate_Right'Access,
 166                        IA.Rotate_Front'Access,
 167                        C3A0011_0.Center'Access,
 168                        IA.Rotate_Back'Access);
 169
 170    -- Build the expected result
 171    Action_Results := ( 270, 0, 90, 95, 0, 355 );
 172
 173    -- Assign actions by invoking subprogram designated by access value
 174    for I in Action_Sequence'Range loop
 175       Action_Sequence(I).all;
 176       if C3A0011_0."/="( C3A0011_0.Heading, Action_Results(I) ) then
 177         Report.Failed ("Expecting "
 178                        & C3A0011_0.Compass_Point'Image(Action_Results(I))
 179                        & " Got"
 180                        & C3A0011_0.Compass_Point'Image(C3A0011_0.Heading));
 181       end if;
 182    end loop;
 183
 184    Report.Result;
 185
 186 end C3A0011;