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