gcc/ada/s-vaflop.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --           S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1997-2005, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This is a dummy body for use on non-Alpha systems so that the library
  35 --  can compile. This dummy version uses ordinary conversions and other
  36 --  arithmetic operations. it is used only for testing purposes in the
  37 --  case where the -gnatdm switch is used to force testing of VMS features
  38 --  on non-VMS systems.
  39
  40 with System.IO; use System.IO;
  41
  42 package body System.Vax_Float_Operations is
  43    pragma Warnings (Off);
  44    --  Warnings about infinite recursion when the -gnatdm switch is used
  45
  46    -----------
  47    -- Abs_F --
  48    -----------
  49
  50    function Abs_F (X : F) return F is
  51    begin
  52       return abs X;
  53    end Abs_F;
  54
  55    -----------
  56    -- Abs_G --
  57    -----------
  58
  59    function Abs_G (X : G) return G is
  60    begin
  61       return abs X;
  62    end Abs_G;
  63
  64    -----------
  65    -- Add_F --
  66    -----------
  67
  68    function Add_F (X, Y : F) return F is
  69    begin
  70       return X + Y;
  71    end Add_F;
  72
  73    -----------
  74    -- Add_G --
  75    -----------
  76
  77    function Add_G (X, Y : G) return G is
  78    begin
  79       return X + Y;
  80    end Add_G;
  81
  82    ------------
  83    -- D_To_G --
  84    ------------
  85
  86    function D_To_G (X : D) return G is
  87    begin
  88       return G (X);
  89    end D_To_G;
  90
  91    --------------------
  92    -- Debug_Output_D --
  93    --------------------
  94
  95    procedure Debug_Output_D (Arg : D) is
  96    begin
  97       Put (D'Image (Arg));
  98    end Debug_Output_D;
  99
 100    --------------------
 101    -- Debug_Output_F --
 102    --------------------
 103
 104    procedure Debug_Output_F (Arg : F) is
 105    begin
 106       Put (F'Image (Arg));
 107    end Debug_Output_F;
 108
 109    --------------------
 110    -- Debug_Output_G --
 111    --------------------
 112
 113    procedure Debug_Output_G (Arg : G) is
 114    begin
 115       Put (G'Image (Arg));
 116    end Debug_Output_G;
 117
 118    --------------------
 119    -- Debug_String_D --
 120    --------------------
 121
 122    Debug_String_Buffer : String (1 .. 32);
 123    --  Buffer used by all Debug_String_x routines for returning result
 124
 125    function Debug_String_D (Arg : D) return System.Address is
 126       Image_String : constant String := D'Image (Arg) & ASCII.NUL;
 127       Image_Size   : constant Integer := Image_String'Length;
 128
 129    begin
 130       Debug_String_Buffer (1 .. Image_Size) := Image_String;
 131       return Debug_String_Buffer (1)'Address;
 132    end Debug_String_D;
 133
 134    --------------------
 135    -- Debug_String_F --
 136    --------------------
 137
 138    function Debug_String_F (Arg : F) return System.Address is
 139       Image_String : constant String := F'Image (Arg) & ASCII.NUL;
 140       Image_Size   : constant Integer := Image_String'Length;
 141
 142    begin
 143       Debug_String_Buffer (1 .. Image_Size) := Image_String;
 144       return Debug_String_Buffer (1)'Address;
 145    end Debug_String_F;
 146
 147    --------------------
 148    -- Debug_String_G --
 149    --------------------
 150
 151    function Debug_String_G (Arg : G) return System.Address is
 152       Image_String : constant String := G'Image (Arg) & ASCII.NUL;
 153       Image_Size   : constant Integer := Image_String'Length;
 154
 155    begin
 156       Debug_String_Buffer (1 .. Image_Size) := Image_String;
 157       return Debug_String_Buffer (1)'Address;
 158    end Debug_String_G;
 159
 160    -----------
 161    -- Div_F --
 162    -----------
 163
 164    function Div_F (X, Y : F) return F is
 165    begin
 166       return X / Y;
 167    end Div_F;
 168
 169    -----------
 170    -- Div_G --
 171    -----------
 172
 173    function Div_G (X, Y : G) return G is
 174    begin
 175       return X / Y;
 176    end Div_G;
 177
 178    ----------
 179    -- Eq_F --
 180    ----------
 181
 182    function Eq_F (X, Y : F) return Boolean is
 183    begin
 184       return X = Y;
 185    end Eq_F;
 186
 187    ----------
 188    -- Eq_G --
 189    ----------
 190
 191    function Eq_G (X, Y : G) return Boolean is
 192    begin
 193       return X = Y;
 194    end Eq_G;
 195
 196    ------------
 197    -- F_To_G --
 198    ------------
 199
 200    function F_To_G (X : F) return G is
 201    begin
 202       return G (X);
 203    end F_To_G;
 204
 205    ------------
 206    -- F_To_Q --
 207    ------------
 208
 209    function F_To_Q (X : F) return Q is
 210    begin
 211       return Q (X);
 212    end F_To_Q;
 213
 214    ------------
 215    -- F_To_S --
 216    ------------
 217
 218    function F_To_S (X : F) return S is
 219    begin
 220       return S (X);
 221    end F_To_S;
 222
 223    ------------
 224    -- G_To_D --
 225    ------------
 226
 227    function G_To_D (X : G) return D is
 228    begin
 229       return D (X);
 230    end G_To_D;
 231
 232    ------------
 233    -- G_To_F --
 234    ------------
 235
 236    function G_To_F (X : G) return F is
 237    begin
 238       return F (X);
 239    end G_To_F;
 240
 241    ------------
 242    -- G_To_Q --
 243    ------------
 244
 245    function G_To_Q (X : G) return Q is
 246    begin
 247       return Q (X);
 248    end G_To_Q;
 249
 250    ------------
 251    -- G_To_T --
 252    ------------
 253
 254    function G_To_T (X : G) return T is
 255    begin
 256       return T (X);
 257    end G_To_T;
 258
 259    ----------
 260    -- Le_F --
 261    ----------
 262
 263    function Le_F (X, Y : F) return Boolean is
 264    begin
 265       return X <= Y;
 266    end Le_F;
 267
 268    ----------
 269    -- Le_G --
 270    ----------
 271
 272    function Le_G (X, Y : G) return Boolean is
 273    begin
 274       return X <= Y;
 275    end Le_G;
 276
 277    ----------
 278    -- Lt_F --
 279    ----------
 280
 281    function Lt_F (X, Y : F) return Boolean is
 282    begin
 283       return X < Y;
 284    end Lt_F;
 285
 286    ----------
 287    -- Lt_G --
 288    ----------
 289
 290    function Lt_G (X, Y : G) return Boolean is
 291    begin
 292       return X < Y;
 293    end Lt_G;
 294
 295    -----------
 296    -- Mul_F --
 297    -----------
 298
 299    function Mul_F (X, Y : F) return F is
 300    begin
 301       return X * Y;
 302    end Mul_F;
 303
 304    -----------
 305    -- Mul_G --
 306    -----------
 307
 308    function Mul_G (X, Y : G) return G is
 309    begin
 310       return X * Y;
 311    end Mul_G;
 312
 313    ----------
 314    -- Ne_F --
 315    ----------
 316
 317    function Ne_F (X, Y : F) return Boolean is
 318    begin
 319       return X /= Y;
 320    end Ne_F;
 321
 322    ----------
 323    -- Ne_G --
 324    ----------
 325
 326    function Ne_G (X, Y : G) return Boolean is
 327    begin
 328       return X /= Y;
 329    end Ne_G;
 330
 331    -----------
 332    -- Neg_F --
 333    -----------
 334
 335    function Neg_F (X : F) return F is
 336    begin
 337       return -X;
 338    end Neg_F;
 339
 340    -----------
 341    -- Neg_G --
 342    -----------
 343
 344    function Neg_G (X : G) return G is
 345    begin
 346       return -X;
 347    end Neg_G;
 348
 349    --------
 350    -- pd --
 351    --------
 352
 353    procedure pd (Arg : D) is
 354    begin
 355       Put_Line (D'Image (Arg));
 356    end pd;
 357
 358    --------
 359    -- pf --
 360    --------
 361
 362    procedure pf (Arg : F) is
 363    begin
 364       Put_Line (F'Image (Arg));
 365    end pf;
 366
 367    --------
 368    -- pg --
 369    --------
 370
 371    procedure pg (Arg : G) is
 372    begin
 373       Put_Line (G'Image (Arg));
 374    end pg;
 375
 376    ------------
 377    -- Q_To_F --
 378    ------------
 379
 380    function Q_To_F (X : Q) return F is
 381    begin
 382       return F (X);
 383    end Q_To_F;
 384
 385    ------------
 386    -- Q_To_G --
 387    ------------
 388
 389    function Q_To_G (X : Q) return G is
 390    begin
 391       return G (X);
 392    end Q_To_G;
 393
 394    ------------
 395    -- S_To_F --
 396    ------------
 397
 398    function S_To_F (X : S) return F is
 399    begin
 400       return F (X);
 401    end S_To_F;
 402
 403    -----------
 404    -- Sub_F --
 405    -----------
 406
 407    function Sub_F (X, Y : F) return F is
 408    begin
 409       return X - Y;
 410    end Sub_F;
 411
 412    -----------
 413    -- Sub_G --
 414    -----------
 415
 416    function Sub_G (X, Y : G) return G is
 417    begin
 418       return X - Y;
 419    end Sub_G;
 420
 421    ------------
 422    -- T_To_D --
 423    ------------
 424
 425    function T_To_D (X : T) return D is
 426    begin
 427       return G_To_D (T_To_G (X));
 428    end T_To_D;
 429
 430    ------------
 431    -- T_To_G --
 432    ------------
 433
 434    function T_To_G (X : T) return G is
 435    begin
 436       return G (X);
 437    end T_To_G;
 438
 439    -------------
 440    -- Valid_D --
 441    -------------
 442
 443    --  For now, convert to IEEE and do Valid test on result. This is not quite
 444    --  accurate, but is good enough in practice.
 445
 446    function Valid_D (Arg : D) return Boolean is
 447       Val : constant T := G_To_T (D_To_G (Arg));
 448    begin
 449       return Val'Valid;
 450    end Valid_D;
 451
 452    -------------
 453    -- Valid_F --
 454    -------------
 455
 456    --  For now, convert to IEEE and do Valid test on result. This is not quite
 457    --  accurate, but is good enough in practice.
 458
 459    function Valid_F (Arg : F) return Boolean is
 460       Val : constant S := F_To_S (Arg);
 461    begin
 462       return Val'Valid;
 463    end Valid_F;
 464
 465    -------------
 466    -- Valid_G --
 467    -------------
 468
 469    --  For now, convert to IEEE and do Valid test on result. This is not quite
 470    --  accurate, but is good enough in practice.
 471
 472    function Valid_G (Arg : G) return Boolean is
 473       Val : constant T := G_To_T (Arg);
 474    begin
 475       return Val'Valid;
 476    end Valid_G;
 477
 478 end System.Vax_Float_Operations;