old-autovect-branch/gcc/testsuite/ada/acats/tests/c3/c3a0005.a

   1 -- C3A0005.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 access to subprogram may be stored within record
  28 --      objects, and that the access to subprogram can subsequently
  29 --      be called.
  30 --
  31 -- TEST DESCRIPTION:
  32 --      Declare an access to procedure type in a package specification.
  33 --      Declare two different procedures that can be referred to by the
  34 --      access to procedure type.  Declare a record with the access to
  35 --      procedure type as a component.  Use the access to procedure type to
  36 --      initialize the component of a record.
  37 --
  38 --      In the main program, declare an operation.  An access value
  39 --      designating this operation is passed as a parameter to be
  40 --      stored in the record.
  41 --
  42 --
  43 -- CHANGE HISTORY:
  44 --      06 Dec 94   SAIC    ACVC 2.0
  45 --
  46 --!
  47
  48 package C3A0005_0 is
  49
  50    Default_Call   : Boolean := False;
  51
  52    type Button;
  53
  54
  55    -- Type accesses to procedures Push and Default_Response
  56    type Button_Response_Ptr is access procedure
  57       (B : access Button);
  58
  59    procedure Push (B : access Button);
  60
  61    procedure Set_Response (B : access Button;
  62                            R : in Button_Response_Ptr);
  63
  64    procedure Default_Response  (B : access Button);
  65
  66    Emergency_Call : Boolean := False;
  67
  68    procedure Emergency (B : access C3A0005_0.Button);
  69
  70    type Button is
  71       record
  72          Response :  Button_Response_Ptr
  73                   := Default_Response'Access;
  74       end record;
  75
  76 end C3A0005_0;
  77
  78
  79 -----------------------------------------------------------------------------
  80
  81 with TCTouch;
  82 package body C3A0005_0 is
  83
  84    procedure Push (B : access Button) is
  85    begin
  86       TCTouch.Touch( 'P' ); --------------------------------------------- P
  87       -- Invoking subprogram designated by access value
  88       B.Response (B);
  89    end Push;
  90
  91
  92    procedure Set_Response (B : access Button;
  93                            R : in     Button_Response_Ptr) is
  94    begin
  95       TCTouch.Touch( 'S' ); --------------------------------------------- S
  96       -- Set procedure value in record
  97       B.Response := R;
  98    end Set_Response;
  99
 100
 101    procedure Default_Response (B : access Button) is
 102    begin
 103       TCTouch.Touch( 'D' ); --------------------------------------------- D
 104       Default_Call := True;
 105    end Default_Response;
 106
 107
 108    procedure Emergency (B : access C3A0005_0.Button) is
 109    begin
 110       TCTouch.Touch( 'E' ); --------------------------------------------- E
 111       Emergency_Call := True;
 112    end Emergency;
 113
 114 end C3A0005_0;
 115
 116
 117 -----------------------------------------------------------------------------
 118
 119 with TCTouch;
 120 with Report;
 121
 122 with C3A0005_0;
 123
 124 procedure C3A0005 is
 125
 126    Big_Red_Button : aliased C3A0005_0.Button;
 127
 128 begin
 129
 130    Report.Test ("C3A0005", "Check that access to subprogram may be "
 131                          & "stored within data structures, and that the "
 132                          & "access to subprogram can subsequently be called");
 133
 134    C3A0005_0.Push (Big_Red_Button'Access);
 135    TCTouch.Validate("PD", "Using default value");
 136    TCTouch.Assert( C3A0005_0.Default_Call, "Default Call" );
 137
 138    -- set Emergency value in Button.Response
 139    C3A0005_0.Set_Response(Big_Red_Button'Access, C3A0005_0.Emergency'Access);
 140
 141    C3A0005_0.Push (Big_Red_Button'Access);
 142    TCTouch.Validate("SPE", "After set to Emergency value");
 143    TCTouch.Assert( C3A0005_0.Emergency_Call, "Emergency Call");
 144
 145    Report.Result;
 146
 147 end C3A0005;