old-autovect-branch/gcc/testsuite/ada/acats/support/fxa5a00.a

   1 -- FXA5A00.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 -- FOUNDATION DESCRIPTION:
  27 --      This foundation package contains constants and a function used in
  28 --      the evaluation of the Generic Elementary Functions.
  29 --
  30 -- CHANGE HISTORY:
  31 --      06 Mar 95   SAIC    Initial prerelease version.
  32 --      03 Apr 95   SAIC    Corrected error in context clause.
  33 --      12 Jun 95   SAIC    Added procedure Dont_Optimize.  Added New_Float
  34 --                          type, and overload of function
  35 --                          Result_Within_Range.
  36 --
  37 --!
  38
  39 with Ada.Numerics;
  40 with Report;
  41
  42 package FXA5A00 is
  43
  44    -- Constants.
  45
  46    Epsilon               : constant Float := Float'Model_Epsilon;
  47    Small                 : constant Float := Float'Model_Small;
  48    Large                 : constant Float := Float'Safe_Last;
  49    Minus_Large           : constant Float := Float'Safe_First;
  50
  51    Half_Pi               : constant Float := Ada.Numerics.Pi / 2.0;
  52    Two_Pi                : constant Float := Ada.Numerics.Pi * 2.0;
  53
  54    Floating_Delta        : constant Float :=  0.05;
  55    One_Plus_Delta        : constant Float :=  1.0 + Floating_Delta;
  56    One_Minus_Delta       : constant Float :=  1.0 - Floating_Delta;
  57    Minus_One_Plus_Delta  : constant Float := -1.0 + Floating_Delta;
  58    Minus_One_Minus_Delta : constant Float := -1.0 - Floating_Delta;
  59
  60
  61    type New_Float is new Float digits 6;
  62
  63    function Result_Within_Range (Result          : Float;
  64                                  Expected_Result : Float;
  65                                  Relative_Error  : Float) return Boolean;
  66
  67    function Result_Within_Range (Result          : New_Float;
  68                                  Expected_Result : Float;
  69                                  Relative_Error  : Float) return Boolean;
  70
  71    -- This procedure is designed to defeat optimization attempts by an
  72    -- implementation in cases where an exception is specifically raised
  73    -- in a test to test a prescribed exception result condition.
  74    -- The parameter Num is a unique identifier for location purposes within
  75    -- the test.
  76
  77    generic
  78       type Eval_Type is digits <>;
  79    procedure Dont_Optimize (Check_Result : Eval_Type;
  80                             Num          : Integer);
  81
  82 end FXA5A00;
  83
  84 ---
  85
  86 package body FXA5A00 is
  87
  88
  89    function Result_Within_Range (Result          : Float;
  90                                  Expected_Result : Float;
  91                                  Relative_Error  : Float) return Boolean is
  92    begin
  93       return (Result <= Expected_Result + Relative_Error) and
  94              (Result >= Expected_Result - Relative_Error);
  95    end Result_Within_Range;
  96
  97
  98    function Result_Within_Range (Result          : New_Float;
  99                                  Expected_Result : Float;
 100                                  Relative_Error  : Float) return Boolean is
 101    begin
 102       return (Float(Result) <= Expected_Result + Relative_Error) and
 103              (Float(Result) >= Expected_Result - Relative_Error);
 104    end Result_Within_Range;
 105
 106
 107    procedure Dont_Optimize (Check_Result : Eval_Type;
 108                             Num          : Integer) is
 109    begin
 110       -- Note that the use of Minus_Large here is simply as a "dummy" value,
 111       -- designed to indicate use of the Check_Result parameter, and has no
 112       -- pass/fail significance to any test using this procedure.
 113       --
 114       if Float(Check_Result) = Minus_Large then
 115          Report.Comment("Attempted Defeat of Optimization ONLY -- Not " &
 116                         "a cause for test failure! "                    &
 117                         "Result = Minus_Large, Case:" & Integer'Image(Num));
 118       end if;
 119    end Dont_Optimize;
 120
 121 end FXA5A00;