gcc/ada/exp_vfpt.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ V F P T                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1997-2002 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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Einfo;    use Einfo;
  29 with Nlists;   use Nlists;
  30 with Nmake;    use Nmake;
  31 with Rtsfind;  use Rtsfind;
  32 with Sem_Res;  use Sem_Res;
  33 with Sinfo;    use Sinfo;
  34 with Snames;   use Snames;
  35 with Stand;    use Stand;
  36 with Tbuild;   use Tbuild;
  37 with Ttypef;   use Ttypef;
  38 with Uintp;    use Uintp;
  39 with Urealp;   use Urealp;
  40
  41 package body Exp_VFpt is
  42
  43    ----------------------
  44    -- Expand_Vax_Arith --
  45    ----------------------
  46
  47    procedure Expand_Vax_Arith (N : Node_Id) is
  48       Loc   : constant Source_Ptr := Sloc (N);
  49       Typ   : constant Entity_Id  := Base_Type (Etype (N));
  50       Typc  : Character;
  51       Atyp  : Entity_Id;
  52       Func  : RE_Id;
  53       Args  : List_Id;
  54
  55    begin
  56       --  Get arithmetic type, note that we do D stuff in G
  57
  58       if Digits_Value (Typ) = VAXFF_Digits then
  59          Typc := 'F';
  60          Atyp := RTE (RE_F);
  61       else
  62          Typc := 'G';
  63          Atyp := RTE (RE_G);
  64       end if;
  65
  66       case Nkind (N) is
  67
  68          when N_Op_Abs =>
  69             if Typc = 'F' then
  70                Func := RE_Abs_F;
  71             else
  72                Func := RE_Abs_G;
  73             end if;
  74
  75          when N_Op_Add =>
  76             if Typc = 'F' then
  77                Func := RE_Add_F;
  78             else
  79                Func := RE_Add_G;
  80             end if;
  81
  82          when N_Op_Divide =>
  83             if Typc = 'F' then
  84                Func := RE_Div_F;
  85             else
  86                Func := RE_Div_G;
  87             end if;
  88
  89          when N_Op_Multiply =>
  90             if Typc = 'F' then
  91                Func := RE_Mul_F;
  92             else
  93                Func := RE_Mul_G;
  94             end if;
  95
  96          when N_Op_Minus =>
  97             if Typc = 'F' then
  98                Func := RE_Neg_F;
  99             else
 100                Func := RE_Neg_G;
 101             end if;
 102
 103          when N_Op_Subtract =>
 104             if Typc = 'F' then
 105                Func := RE_Sub_F;
 106             else
 107                Func := RE_Sub_G;
 108             end if;
 109
 110          when others =>
 111             Func := RE_Null;
 112             raise Program_Error;
 113
 114       end case;
 115
 116       Args := New_List;
 117
 118       if Nkind (N) in N_Binary_Op then
 119          Append_To (Args,
 120            Convert_To (Atyp, Left_Opnd (N)));
 121       end if;
 122
 123       Append_To (Args,
 124         Convert_To (Atyp, Right_Opnd (N)));
 125
 126       Rewrite (N,
 127         Convert_To (Typ,
 128           Make_Function_Call (Loc,
 129             Name => New_Occurrence_Of (RTE (Func), Loc),
 130             Parameter_Associations => Args)));
 131
 132       Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
 133    end Expand_Vax_Arith;
 134
 135    ---------------------------
 136    -- Expand_Vax_Comparison --
 137    ---------------------------
 138
 139    procedure Expand_Vax_Comparison (N : Node_Id) is
 140       Loc   : constant Source_Ptr := Sloc (N);
 141       Typ   : constant Entity_Id  := Base_Type (Etype (Left_Opnd (N)));
 142       Typc  : Character;
 143       Func  : RE_Id;
 144       Atyp  : Entity_Id;
 145       Revrs : Boolean := False;
 146       Args  : List_Id;
 147
 148    begin
 149       --  Get arithmetic type, note that we do D stuff in G
 150
 151       if Digits_Value (Typ) = VAXFF_Digits then
 152          Typc := 'F';
 153          Atyp := RTE (RE_F);
 154       else
 155          Typc := 'G';
 156          Atyp := RTE (RE_G);
 157       end if;
 158
 159       case Nkind (N) is
 160
 161          when N_Op_Eq =>
 162             if Typc = 'F' then
 163                Func := RE_Eq_F;
 164             else
 165                Func := RE_Eq_G;
 166             end if;
 167
 168          when N_Op_Ge =>
 169             if Typc = 'F' then
 170                Func := RE_Le_F;
 171             else
 172                Func := RE_Le_G;
 173             end if;
 174
 175             Revrs := True;
 176
 177          when N_Op_Gt =>
 178             if Typc = 'F' then
 179                Func := RE_Lt_F;
 180             else
 181                Func := RE_Lt_G;
 182             end if;
 183
 184             Revrs := True;
 185
 186          when N_Op_Le =>
 187             if Typc = 'F' then
 188                Func := RE_Le_F;
 189             else
 190                Func := RE_Le_G;
 191             end if;
 192
 193          when N_Op_Lt =>
 194             if Typc = 'F' then
 195                Func := RE_Lt_F;
 196             else
 197                Func := RE_Lt_G;
 198             end if;
 199
 200          when others =>
 201             Func := RE_Null;
 202             raise Program_Error;
 203
 204       end case;
 205
 206       if not Revrs then
 207          Args := New_List (
 208            Convert_To (Atyp, Left_Opnd  (N)),
 209            Convert_To (Atyp, Right_Opnd (N)));
 210
 211       else
 212          Args := New_List (
 213            Convert_To (Atyp, Right_Opnd (N)),
 214            Convert_To (Atyp, Left_Opnd  (N)));
 215       end if;
 216
 217       Rewrite (N,
 218         Make_Function_Call (Loc,
 219           Name => New_Occurrence_Of (RTE (Func), Loc),
 220           Parameter_Associations => Args));
 221
 222       Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
 223    end Expand_Vax_Comparison;
 224
 225    ---------------------------
 226    -- Expand_Vax_Conversion --
 227    ---------------------------
 228
 229    procedure Expand_Vax_Conversion (N : Node_Id) is
 230       Loc   : constant Source_Ptr := Sloc (N);
 231       Expr  : constant Node_Id    := Expression (N);
 232       S_Typ : constant Entity_Id  := Base_Type (Etype (Expr));
 233       T_Typ : constant Entity_Id  := Base_Type (Etype (N));
 234
 235       CallS : RE_Id;
 236       CallT : RE_Id;
 237       Func  : RE_Id;
 238
 239       function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id;
 240       --  Given one of the two types T, determines the coresponding call
 241       --  type, i.e. the type to be used for the call (or the result of
 242       --  the call). The actual operand is converted to (or from) this type.
 243       --  Otyp is the other type, which is useful in figuring out the result.
 244       --  The result returned is the RE_Id value for the type entity.
 245
 246       function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id;
 247       --  Find the predefined integer type that has the same size as the
 248       --  fixed-point type T, for use in fixed/float conversions.
 249
 250       ---------------
 251       -- Call_Type --
 252       ---------------
 253
 254       function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id is
 255       begin
 256          --  Vax float formats
 257
 258          if Vax_Float (T) then
 259             if Digits_Value (T) = VAXFF_Digits then
 260                return RE_F;
 261
 262             elsif Digits_Value (T) = VAXGF_Digits then
 263                return RE_G;
 264
 265             --  For D_Float, leave it as D float if the other operand is
 266             --  G_Float, since this is the one conversion that is properly
 267             --  supported for D_Float, but otherwise, use G_Float.
 268
 269             else pragma Assert (Digits_Value (T) = VAXDF_Digits);
 270
 271                if Vax_Float (Otyp)
 272                  and then Digits_Value (Otyp) = VAXGF_Digits
 273                then
 274                   return RE_D;
 275                else
 276                   return RE_G;
 277                end if;
 278             end if;
 279
 280          --  For all discrete types, use 64-bit integer
 281
 282          elsif Is_Discrete_Type (T) then
 283             return RE_Q;
 284
 285          --  For all real types (other than Vax float format), we use the
 286          --  IEEE float-type which corresponds in length to the other type
 287          --  (which is Vax Float).
 288
 289          else pragma Assert (Is_Real_Type (T));
 290
 291             if Digits_Value (Otyp) = VAXFF_Digits then
 292                return RE_S;
 293             else
 294                return RE_T;
 295             end if;
 296          end if;
 297       end Call_Type;
 298
 299       function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is
 300       begin
 301          if Esize (T) = Esize (Standard_Long_Long_Integer) then
 302             return Standard_Long_Long_Integer;
 303
 304          elsif Esize (T) = Esize (Standard_Long_Integer) then
 305             return  Standard_Long_Integer;
 306
 307          else
 308             return Standard_Integer;
 309          end if;
 310       end Equivalent_Integer_Type;
 311
 312    --  Start of processing for Expand_Vax_Conversion;
 313
 314    begin
 315       --  If input and output are the same Vax type, we change the
 316       --  conversion to be an unchecked conversion and that's it.
 317
 318       if Vax_Float (S_Typ) and then Vax_Float (T_Typ)
 319         and then Digits_Value (S_Typ) = Digits_Value (T_Typ)
 320       then
 321          Rewrite (N,
 322            Unchecked_Convert_To (T_Typ, Expr));
 323
 324       elsif Is_Fixed_Point_Type (S_Typ) then
 325
 326          --  convert the scaled integer value to the target type, and multiply
 327          --  by 'Small of type.
 328
 329          Rewrite (N,
 330             Make_Op_Multiply (Loc,
 331               Left_Opnd =>
 332                 Make_Type_Conversion (Loc,
 333                   Subtype_Mark => New_Occurrence_Of (T_Typ, Loc),
 334                   Expression   =>
 335                     Unchecked_Convert_To (
 336                       Equivalent_Integer_Type (S_Typ), Expr)),
 337               Right_Opnd =>
 338                 Make_Real_Literal (Loc, Realval => Small_Value (S_Typ))));
 339
 340       elsif Is_Fixed_Point_Type (T_Typ) then
 341
 342          --  multiply value by 'small of type, and convert to the corresponding
 343          --  integer type.
 344
 345          Rewrite (N,
 346            Unchecked_Convert_To (T_Typ,
 347              Make_Type_Conversion (Loc,
 348                Subtype_Mark =>
 349                  New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc),
 350                Expression =>
 351                  Make_Op_Multiply (Loc,
 352                    Left_Opnd => Expr,
 353                    Right_Opnd =>
 354                      Make_Real_Literal (Loc,
 355                        Realval => Ureal_1 / Small_Value (T_Typ))))));
 356
 357       --  All other cases.
 358
 359       else
 360          --  Compute types for call
 361
 362          CallS := Call_Type (S_Typ, T_Typ);
 363          CallT := Call_Type (T_Typ, S_Typ);
 364
 365          --  Get function and its types
 366
 367          if CallS = RE_D and then CallT = RE_G then
 368             Func := RE_D_To_G;
 369
 370          elsif CallS = RE_G and then CallT = RE_D then
 371             Func := RE_G_To_D;
 372
 373          elsif CallS = RE_G and then CallT = RE_F then
 374             Func := RE_G_To_F;
 375
 376          elsif CallS = RE_F and then CallT = RE_G then
 377             Func := RE_F_To_G;
 378
 379          elsif CallS = RE_F and then CallT = RE_S then
 380             Func := RE_F_To_S;
 381
 382          elsif CallS = RE_S and then CallT = RE_F then
 383             Func := RE_S_To_F;
 384
 385          elsif CallS = RE_G and then CallT = RE_T then
 386             Func := RE_G_To_T;
 387
 388          elsif CallS = RE_T and then CallT = RE_G then
 389             Func := RE_T_To_G;
 390
 391          elsif CallS = RE_F and then CallT = RE_Q then
 392             Func := RE_F_To_Q;
 393
 394          elsif CallS = RE_Q and then CallT = RE_F then
 395             Func := RE_Q_To_F;
 396
 397          elsif CallS = RE_G and then CallT = RE_Q then
 398             Func := RE_G_To_Q;
 399
 400          else pragma Assert (CallS = RE_Q and then CallT = RE_G);
 401             Func := RE_Q_To_G;
 402          end if;
 403
 404          Rewrite (N,
 405            Convert_To (T_Typ,
 406              Make_Function_Call (Loc,
 407                Name => New_Occurrence_Of (RTE (Func), Loc),
 408                Parameter_Associations => New_List (
 409                  Convert_To (RTE (CallS), Expr)))));
 410       end if;
 411
 412       Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks);
 413    end Expand_Vax_Conversion;
 414
 415    -----------------------------
 416    -- Expand_Vax_Real_Literal --
 417    -----------------------------
 418
 419    procedure Expand_Vax_Real_Literal (N : Node_Id) is
 420       Loc  : constant Source_Ptr := Sloc (N);
 421       Typ  : constant Entity_Id  := Etype (N);
 422       Btyp : constant Entity_Id  := Base_Type (Typ);
 423       Stat : constant Boolean    := Is_Static_Expression (N);
 424       Nod  : Node_Id;
 425
 426       RE_Source : RE_Id;
 427       RE_Target : RE_Id;
 428       RE_Fncall : RE_Id;
 429       --  Entities for source, target and function call in conversion
 430
 431    begin
 432       --  We do not know how to convert Vax format real literals, so what
 433       --  we do is to convert these to be IEEE literals, and introduce the
 434       --  necessary conversion operation.
 435
 436       if Vax_Float (Btyp) then
 437          --  What we want to construct here is
 438
 439          --    x!(y_to_z (1.0E0))
 440
 441          --  where
 442
 443          --    x is the base type of the literal (Btyp)
 444
 445          --    y_to_z is
 446
 447          --      s_to_f for F_Float
 448          --      t_to_g for G_Float
 449          --      t_to_d for D_Float
 450
 451          --  The literal is typed as S (for F_Float) or T otherwise
 452
 453          --  We do all our own construction, analysis, and expansion here,
 454          --  since things are at too low a level to use Analyze or Expand
 455          --  to get this built (we get circularities and other strange
 456          --  problems if we try!)
 457
 458          if Digits_Value (Btyp) = VAXFF_Digits then
 459             RE_Source := RE_S;
 460             RE_Target := RE_F;
 461             RE_Fncall := RE_S_To_F;
 462
 463          elsif Digits_Value (Btyp) = VAXDF_Digits then
 464             RE_Source := RE_T;
 465             RE_Target := RE_D;
 466             RE_Fncall := RE_T_To_D;
 467
 468          else pragma Assert (Digits_Value (Btyp) = VAXGF_Digits);
 469             RE_Source := RE_T;
 470             RE_Target := RE_G;
 471             RE_Fncall := RE_T_To_G;
 472          end if;
 473
 474          Nod := Relocate_Node (N);
 475
 476          Set_Etype (Nod, RTE (RE_Source));
 477          Set_Analyzed (Nod, True);
 478
 479          Nod :=
 480            Make_Function_Call (Loc,
 481              Name => New_Occurrence_Of (RTE (RE_Fncall), Loc),
 482              Parameter_Associations => New_List (Nod));
 483
 484          Set_Etype (Nod, RTE (RE_Target));
 485          Set_Analyzed (Nod, True);
 486
 487          Nod :=
 488            Make_Unchecked_Type_Conversion (Loc,
 489              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
 490              Expression   => Nod);
 491
 492          Set_Etype (Nod, Typ);
 493          Set_Analyzed (Nod, True);
 494          Rewrite (N, Nod);
 495
 496          --  This odd expression is still a static expression. Note that
 497          --  the routine Sem_Eval.Expr_Value_R understands this.
 498
 499          Set_Is_Static_Expression (N, Stat);
 500       end if;
 501    end Expand_Vax_Real_Literal;
 502
 503 end Exp_VFpt;