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