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