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