gcc/ada/sem_vfpt.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ V F P T                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --          Copyright (C) 1997-2002, 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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with CStand;   use CStand;
  29 with Einfo;    use Einfo;
  30 with Opt;      use Opt;
  31 with Stand;    use Stand;
  32 with Targparm; use Targparm;
  33 with Ttypef;   use Ttypef;
  34
  35 package body Sem_VFpt is
  36
  37    -----------------
  38    -- Set_D_Float --
  39    -----------------
  40
  41    procedure Set_D_Float (E : Entity_Id) is
  42    begin
  43       Init_Size         (Base_Type (E), 64);
  44       Init_Alignment    (Base_Type (E));
  45       Init_Digits_Value (Base_Type (E), VAXDF_Digits);
  46       Set_Vax_Float     (Base_Type (E), True);
  47       Set_Float_Bounds  (Base_Type (E));
  48
  49       Init_Size         (E, 64);
  50       Init_Alignment    (E);
  51       Init_Digits_Value (E, VAXDF_Digits);
  52       Set_Scalar_Range  (E, Scalar_Range (Base_Type (E)));
  53    end Set_D_Float;
  54
  55    -----------------
  56    -- Set_F_Float --
  57    -----------------
  58
  59    procedure Set_F_Float (E : Entity_Id) is
  60    begin
  61       Init_Size         (Base_Type (E), 32);
  62       Init_Alignment    (Base_Type (E));
  63       Init_Digits_Value (Base_Type (E), VAXFF_Digits);
  64       Set_Vax_Float     (Base_Type (E), True);
  65       Set_Float_Bounds  (Base_Type (E));
  66
  67       Init_Size         (E, 32);
  68       Init_Alignment    (E);
  69       Init_Digits_Value (E, VAXFF_Digits);
  70       Set_Scalar_Range  (E, Scalar_Range (Base_Type (E)));
  71    end Set_F_Float;
  72
  73    -----------------
  74    -- Set_G_Float --
  75    -----------------
  76
  77    procedure Set_G_Float (E : Entity_Id) is
  78    begin
  79       Init_Size         (Base_Type (E), 64);
  80       Init_Alignment    (Base_Type (E));
  81       Init_Digits_Value (Base_Type (E), VAXGF_Digits);
  82       Set_Vax_Float     (Base_Type (E), True);
  83       Set_Float_Bounds  (Base_Type (E));
  84
  85       Init_Size         (E, 64);
  86       Init_Alignment    (E);
  87       Init_Digits_Value (E, VAXGF_Digits);
  88       Set_Scalar_Range  (E, Scalar_Range (Base_Type (E)));
  89    end Set_G_Float;
  90
  91    -------------------
  92    -- Set_IEEE_Long --
  93    -------------------
  94
  95    procedure Set_IEEE_Long (E : Entity_Id) is
  96    begin
  97       Init_Size         (Base_Type (E), 64);
  98       Init_Alignment    (Base_Type (E));
  99       Init_Digits_Value (Base_Type (E), IEEEL_Digits);
 100       Set_Vax_Float     (Base_Type (E), False);
 101       Set_Float_Bounds  (Base_Type (E));
 102
 103       Init_Size         (E, 64);
 104       Init_Alignment    (E);
 105       Init_Digits_Value (E, IEEEL_Digits);
 106       Set_Scalar_Range  (E, Scalar_Range (Base_Type (E)));
 107    end Set_IEEE_Long;
 108
 109    --------------------
 110    -- Set_IEEE_Short --
 111    --------------------
 112
 113    procedure Set_IEEE_Short (E : Entity_Id) is
 114    begin
 115       Init_Size         (Base_Type (E), 32);
 116       Init_Alignment    (Base_Type (E));
 117       Init_Digits_Value (Base_Type (E), IEEES_Digits);
 118       Set_Vax_Float     (Base_Type (E), False);
 119       Set_Float_Bounds  (Base_Type (E));
 120
 121       Init_Size         (E, 32);
 122       Init_Alignment    (E);
 123       Init_Digits_Value (E, IEEES_Digits);
 124       Set_Scalar_Range  (E, Scalar_Range (Base_Type (E)));
 125    end Set_IEEE_Short;
 126
 127    ------------------------------
 128    -- Set_Standard_Fpt_Formats --
 129    ------------------------------
 130
 131    procedure Set_Standard_Fpt_Formats is
 132    begin
 133       --  IEEE case
 134
 135       if Opt.Float_Format = 'I' then
 136          Set_IEEE_Short (Standard_Float);
 137          Set_IEEE_Long  (Standard_Long_Float);
 138          Set_IEEE_Long  (Standard_Long_Long_Float);
 139
 140       --  Vax float case
 141
 142       else
 143          Set_F_Float (Standard_Float);
 144
 145          if Opt.Float_Format_Long = 'D' then
 146             Set_D_Float (Standard_Long_Float);
 147          else
 148             Set_G_Float (Standard_Long_Float);
 149          end if;
 150
 151          --  Note: Long_Long_Float gets set only in the real VMS case,
 152          --  because this gives better results for testing out the use
 153          --  of VAX float on non-VMS environments with the -gnatdm switch.
 154
 155          if OpenVMS_On_Target then
 156             Set_G_Float (Standard_Long_Long_Float);
 157          end if;
 158       end if;
 159    end Set_Standard_Fpt_Formats;
 160
 161 end Sem_VFpt;