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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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    -- Neg_F --
 315    -----------
 316
 317    function Neg_F (X : F) return F is
 318    begin
 319       return -X;
 320    end Neg_F;
 321
 322    -----------
 323    -- Neg_G --
 324    -----------
 325
 326    function Neg_G (X : G) return G is
 327    begin
 328       return -X;
 329    end Neg_G;
 330
 331    --------
 332    -- pd --
 333    --------
 334
 335    procedure pd (Arg : D) is
 336    begin
 337       Put_Line (D'Image (Arg));
 338    end pd;
 339
 340    --------
 341    -- pf --
 342    --------
 343
 344    procedure pf (Arg : F) is
 345    begin
 346       Put_Line (F'Image (Arg));
 347    end pf;
 348
 349    --------
 350    -- pg --
 351    --------
 352
 353    procedure pg (Arg : G) is
 354    begin
 355       Put_Line (G'Image (Arg));
 356    end pg;
 357
 358    ------------
 359    -- Q_To_F --
 360    ------------
 361
 362    function Q_To_F (X : Q) return F is
 363    begin
 364       return F (X);
 365    end Q_To_F;
 366
 367    ------------
 368    -- Q_To_G --
 369    ------------
 370
 371    function Q_To_G (X : Q) return G is
 372    begin
 373       return G (X);
 374    end Q_To_G;
 375
 376    ------------
 377    -- S_To_F --
 378    ------------
 379
 380    function S_To_F (X : S) return F is
 381    begin
 382       return F (X);
 383    end S_To_F;
 384
 385    -----------
 386    -- Sub_F --
 387    -----------
 388
 389    function Sub_F (X, Y : F) return F is
 390    begin
 391       return X - Y;
 392    end Sub_F;
 393
 394    -----------
 395    -- Sub_G --
 396    -----------
 397
 398    function Sub_G (X, Y : G) return G is
 399    begin
 400       return X - Y;
 401    end Sub_G;
 402
 403    ------------
 404    -- T_To_D --
 405    ------------
 406
 407    function T_To_D (X : T) return D is
 408    begin
 409       return G_To_D (T_To_G (X));
 410    end T_To_D;
 411
 412    ------------
 413    -- T_To_G --
 414    ------------
 415
 416    function T_To_G (X : T) return G is
 417    begin
 418       return G (X);
 419    end T_To_G;
 420
 421 end System.Vax_Float_Operations;