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