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

   1 -- C3A0006.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 data
  28 --      structures, and that the access to subprogram can subsequently
  29 --      be called.
  30 --
  31 -- TEST DESCRIPTION:
  32 --      Declare an access to function type in a package specification.
  33 --      Declare an array of the access type.  Declare three different
  34 --      functions that can be referred to by the access to function type.
  35 --
  36 --      In the main program, declare a key function that builds the array
  37 --      by calling each function indirectly through the access value.
  38 --
  39 --
  40 -- CHANGE HISTORY:
  41 --      06 Dec 94   SAIC    ACVC 2.0
  42 --
  43 --!
  44
  45
  46 package C3A0006_0 is
  47
  48    TC_Sine_Call  : Integer := 0;
  49    TC_Cos_Call   : Integer := 0;
  50    TC_Tan_Call   : Integer := 0;
  51
  52    Sine_Value    : Float :=  4.0;
  53    Cos_Value     : Float :=  8.0;
  54    Tan_Value     : Float := 10.0;
  55
  56    -- Type accesses to any function
  57    type Trig_Function_Ptr is access function
  58       (Angle : in Float) return Float;
  59
  60    function Sine (Angle : in Float) return Float;
  61
  62    function Cos  (Angle : in Float) return Float;
  63
  64    function Tan  (Angle : in Float) return Float;
  65
  66 end C3A0006_0;
  67
  68
  69 -----------------------------------------------------------------------------
  70
  71
  72 package body C3A0006_0 is
  73
  74    function Sine (Angle : in Float) return Float is
  75    begin
  76      TC_Sine_Call := TC_Sine_Call + 1;
  77      Sine_Value := Sine_Value + Angle;
  78      return Sine_Value;
  79    end Sine;
  80
  81
  82    function Cos  (Angle: in Float) return Float is
  83    begin
  84      TC_Cos_Call := TC_Cos_Call + 1;
  85      Cos_Value := Cos_Value - Angle;
  86      return Cos_Value;
  87    end Cos;
  88
  89
  90    function Tan (Angle : in Float) return Float is
  91    begin
  92      TC_Tan_Call := TC_Tan_Call + 1;
  93      Tan_Value := (Tan_Value + (Tan_Value * Angle));
  94      return Tan_Value;
  95    end Tan;
  96
  97
  98 end C3A0006_0;
  99
 100 -----------------------------------------------------------------------------
 101
 102
 103 with Report;
 104
 105 with C3A0006_0;
 106
 107 procedure C3A0006 is
 108
 109    Trig_Value, Theta  : Float := 0.0;
 110
 111    Total_Routines     : constant := 3;
 112
 113    Sine_Total         : constant := 7.0;
 114    Cos_Total          : constant := 5.0;
 115    Tan_Total          : constant := 75.0;
 116
 117    Trig_Table : array (1 .. Total_Routines) of C3A0006_0.Trig_Function_Ptr;
 118
 119
 120    -- Key function to build the table
 121    function Call_Trig_Func (Func : C3A0006_0.Trig_Function_Ptr;
 122                             Operand : Float) return Float is
 123    begin
 124       return (Func(Operand));
 125    end Call_Trig_Func;
 126
 127
 128 begin
 129
 130    Report.Test ("C3A0006", "Check that access to subprogram may be " &
 131                 "stored within data structures, and that the access " &
 132                 "to subprogram can subsequently be called");
 133
 134    Trig_Table := (C3A0006_0.Sine'Access, C3A0006_0.Cos'Access,
 135                   C3A0006_0.Tan'Access);
 136
 137    -- increase the value of Theta to build the table
 138    for I in 1 .. Total_Routines loop
 139       Theta := Theta + 0.5;
 140       for J in 1 .. Total_Routines loop
 141          Trig_Value     := Call_Trig_Func (Trig_Table(J), Theta);
 142       end loop;
 143    end loop;
 144
 145    if C3A0006_0.TC_Sine_Call /= Total_Routines
 146      or C3A0006_0.TC_Cos_Call /= Total_Routines
 147      or C3A0006_0.TC_Tan_Call /= Total_Routines then
 148         Report.Failed ("Incorrect subprograms result");
 149    end if;
 150
 151    if C3A0006_0.Sine_Value /= Sine_Total
 152      or C3A0006_0.Cos_Value /= Cos_Total
 153      or C3A0006_0.Tan_Value /= Tan_Total then
 154         Report.Failed ("Incorrect values returned from subprograms");
 155    end if;
 156
 157    if Trig_Value /= Tan_Total then
 158         Report.Failed ("Incorrect call order.");
 159    end if;
 160
 161    Report.Result;
 162
 163 end C3A0006;