gcc/ada/exp_fixd.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ F I X D                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2008, 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 Checks;   use Checks;
  28 with Einfo;    use Einfo;
  29 with Exp_Util; use Exp_Util;
  30 with Nlists;   use Nlists;
  31 with Nmake;    use Nmake;
  32 with Rtsfind;  use Rtsfind;
  33 with Sem;      use Sem;
  34 with Sem_Eval; use Sem_Eval;
  35 with Sem_Res;  use Sem_Res;
  36 with Sem_Util; use Sem_Util;
  37 with Sinfo;    use Sinfo;
  38 with Stand;    use Stand;
  39 with Tbuild;   use Tbuild;
  40 with Uintp;    use Uintp;
  41 with Urealp;   use Urealp;
  42
  43 package body Exp_Fixd is
  44
  45    -----------------------
  46    -- Local Subprograms --
  47    -----------------------
  48
  49    --  General note; in this unit, a number of routines are driven by the
  50    --  types (Etype) of their operands. Since we are dealing with unanalyzed
  51    --  expressions as they are constructed, the Etypes would not normally be
  52    --  set, but the construction routines that we use in this unit do in fact
  53    --  set the Etype values correctly. In addition, setting the Etype ensures
  54    --  that the analyzer does not try to redetermine the type when the node
  55    --  is analyzed (which would be wrong, since in the case where we set the
  56    --  Treat_Fixed_As_Integer or Conversion_OK flags, it would think it was
  57    --  still dealing with a normal fixed-point operation and mess it up).
  58
  59    function Build_Conversion
  60      (N    : Node_Id;
  61       Typ  : Entity_Id;
  62       Expr : Node_Id;
  63       Rchk : Boolean := False) return Node_Id;
  64    --  Build an expression that converts the expression Expr to type Typ,
  65    --  taking the source location from Sloc (N). If the conversions involve
  66    --  fixed-point types, then the Conversion_OK flag will be set so that the
  67    --  resulting conversions do not get re-expanded. On return the resulting
  68    --  node has its Etype set. If Rchk is set, then Do_Range_Check is set
  69    --  in the resulting conversion node.
  70
  71    function Build_Divide (N : Node_Id; L, R : Node_Id) return Node_Id;
  72    --  Builds an N_Op_Divide node from the given left and right operand
  73    --  expressions, using the source location from Sloc (N). The operands are
  74    --  either both Universal_Real, in which case Build_Divide differs from
  75    --  Make_Op_Divide only in that the Etype of the resulting node is set (to
  76    --  Universal_Real), or they can be integer types. In this case the integer
  77    --  types need not be the same, and Build_Divide converts the operand with
  78    --  the smaller sized type to match the type of the other operand and sets
  79    --  this as the result type. The Rounded_Result flag of the result in this
  80    --  case is set from the Rounded_Result flag of node N. On return, the
  81    --  resulting node is analyzed, and has its Etype set.
  82
  83    function Build_Double_Divide
  84      (N       : Node_Id;
  85       X, Y, Z : Node_Id) return Node_Id;
  86    --  Returns a node corresponding to the value X/(Y*Z) using the source
  87    --  location from Sloc (N). The division is rounded if the Rounded_Result
  88    --  flag of N is set. The integer types of X, Y, Z may be different. On
  89    --  return the resulting node is analyzed, and has its Etype set.
  90
  91    procedure Build_Double_Divide_Code
  92      (N        : Node_Id;
  93       X, Y, Z  : Node_Id;
  94       Qnn, Rnn : out Entity_Id;
  95       Code     : out List_Id);
  96    --  Generates a sequence of code for determining the quotient and remainder
  97    --  of the division X/(Y*Z), using the source location from Sloc (N).
  98    --  Entities of appropriate types are allocated for the quotient and
  99    --  remainder and returned in Qnn and Rnn. The result is rounded if the
 100    --  Rounded_Result flag of N is set. The Etype fields of Qnn and Rnn are
 101    --  appropriately set on return.
 102
 103    function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id;
 104    --  Builds an N_Op_Multiply node from the given left and right operand
 105    --  expressions, using the source location from Sloc (N). The operands are
 106    --  either both Universal_Real, in which case Build_Multiply differs from
 107    --  Make_Op_Multiply only in that the Etype of the resulting node is set (to
 108    --  Universal_Real), or they can be integer types. In this case the integer
 109    --  types need not be the same, and Build_Multiply chooses a type long
 110    --  enough to hold the product (i.e. twice the size of the longer of the two
 111    --  operand types), and both operands are converted to this type. The Etype
 112    --  of the result is also set to this value. However, the result can never
 113    --  overflow Integer_64, so this is the largest type that is ever generated.
 114    --  On return, the resulting node is analyzed and has its Etype set.
 115
 116    function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id;
 117    --  Builds an N_Op_Rem node from the given left and right operand
 118    --  expressions, using the source location from Sloc (N). The operands are
 119    --  both integer types, which need not be the same. Build_Rem converts the
 120    --  operand with the smaller sized type to match the type of the other
 121    --  operand and sets this as the result type. The result is never rounded
 122    --  (rem operations cannot be rounded in any case!) On return, the resulting
 123    --  node is analyzed and has its Etype set.
 124
 125    function Build_Scaled_Divide
 126      (N       : Node_Id;
 127       X, Y, Z : Node_Id) return Node_Id;
 128    --  Returns a node corresponding to the value X*Y/Z using the source
 129    --  location from Sloc (N). The division is rounded if the Rounded_Result
 130    --  flag of N is set. The integer types of X, Y, Z may be different. On
 131    --  return the resulting node is analyzed and has is Etype set.
 132
 133    procedure Build_Scaled_Divide_Code
 134      (N        : Node_Id;
 135       X, Y, Z  : Node_Id;
 136       Qnn, Rnn : out Entity_Id;
 137       Code     : out List_Id);
 138    --  Generates a sequence of code for determining the quotient and remainder
 139    --  of the division X*Y/Z, using the source location from Sloc (N). Entities
 140    --  of appropriate types are allocated for the quotient and remainder and
 141    --  returned in Qnn and Rrr. The integer types for X, Y, Z may be different.
 142    --  The division is rounded if the Rounded_Result flag of N is set. The
 143    --  Etype fields of Qnn and Rnn are appropriately set on return.
 144
 145    procedure Do_Divide_Fixed_Fixed (N : Node_Id);
 146    --  Handles expansion of divide for case of two fixed-point operands
 147    --  (neither of them universal), with an integer or fixed-point result.
 148    --  N is the N_Op_Divide node to be expanded.
 149
 150    procedure Do_Divide_Fixed_Universal (N : Node_Id);
 151    --  Handles expansion of divide for case of a fixed-point operand divided
 152    --  by a universal real operand, with an integer or fixed-point result. N
 153    --  is the N_Op_Divide node to be expanded.
 154
 155    procedure Do_Divide_Universal_Fixed (N : Node_Id);
 156    --  Handles expansion of divide for case of a universal real operand
 157    --  divided by a fixed-point operand, with an integer or fixed-point
 158    --  result. N is the N_Op_Divide node to be expanded.
 159
 160    procedure Do_Multiply_Fixed_Fixed (N : Node_Id);
 161    --  Handles expansion of multiply for case of two fixed-point operands
 162    --  (neither of them universal), with an integer or fixed-point result.
 163    --  N is the N_Op_Multiply node to be expanded.
 164
 165    procedure Do_Multiply_Fixed_Universal (N : Node_Id; Left, Right : Node_Id);
 166    --  Handles expansion of multiply for case of a fixed-point operand
 167    --  multiplied by a universal real operand, with an integer or fixed-
 168    --  point result. N is the N_Op_Multiply node to be expanded, and
 169    --  Left, Right are the operands (which may have been switched).
 170
 171    procedure Expand_Convert_Fixed_Static (N : Node_Id);
 172    --  This routine is called where the node N is a conversion of a literal
 173    --  or other static expression of a fixed-point type to some other type.
 174    --  In such cases, we simply rewrite the operand as a real literal and
 175    --  reanalyze. This avoids problems which would otherwise result from
 176    --  attempting to build and fold expressions involving constants.
 177
 178    function Fpt_Value (N : Node_Id) return Node_Id;
 179    --  Given an operand of fixed-point operation, return an expression that
 180    --  represents the corresponding Universal_Real value. The expression
 181    --  can be of integer type, floating-point type, or fixed-point type.
 182    --  The expression returned is neither analyzed and resolved. The Etype
 183    --  of the result is properly set (to Universal_Real).
 184
 185    function Integer_Literal
 186      (N        : Node_Id;
 187       V        : Uint;
 188       Negative : Boolean := False) return Node_Id;
 189    --  Given a non-negative universal integer value, build a typed integer
 190    --  literal node, using the smallest applicable standard integer type. If
 191    --  and only if Negative is true a negative literal is built. If V exceeds
 192    --  2**63-1, the largest value allowed for perfect result set scaling
 193    --  factors (see RM G.2.3(22)), then Empty is returned. The node N provides
 194    --  the Sloc value for the constructed literal. The Etype of the resulting
 195    --  literal is correctly set, and it is marked as analyzed.
 196
 197    function Real_Literal (N : Node_Id; V : Ureal) return Node_Id;
 198    --  Build a real literal node from the given value, the Etype of the
 199    --  returned node is set to Universal_Real, since all floating-point
 200    --  arithmetic operations that we construct use Universal_Real
 201
 202    function Rounded_Result_Set (N : Node_Id) return Boolean;
 203    --  Returns True if N is a node that contains the Rounded_Result flag
 204    --  and if the flag is true or the target type is an integer type.
 205
 206    procedure Set_Result (N : Node_Id; Expr : Node_Id; Rchk : Boolean := False);
 207    --  N is the node for the current conversion, division or multiplication
 208    --  operation, and Expr is an expression representing the result. Expr may
 209    --  be of floating-point or integer type. If the operation result is fixed-
 210    --  point, then the value of Expr is in units of small of the result type
 211    --  (i.e. small's have already been dealt with). The result of the call is
 212    --  to replace N by an appropriate conversion to the result type, dealing
 213    --  with rounding for the decimal types case. The node is then analyzed and
 214    --  resolved using the result type. If Rchk is True, then Do_Range_Check is
 215    --  set in the resulting conversion.
 216
 217    ----------------------
 218    -- Build_Conversion --
 219    ----------------------
 220
 221    function Build_Conversion
 222      (N    : Node_Id;
 223       Typ  : Entity_Id;
 224       Expr : Node_Id;
 225       Rchk : Boolean := False) return Node_Id
 226    is
 227       Loc    : constant Source_Ptr := Sloc (N);
 228       Result : Node_Id;
 229       Rcheck : Boolean := Rchk;
 230
 231    begin
 232       --  A special case, if the expression is an integer literal and the
 233       --  target type is an integer type, then just retype the integer
 234       --  literal to the desired target type. Don't do this if we need
 235       --  a range check.
 236
 237       if Nkind (Expr) = N_Integer_Literal
 238         and then Is_Integer_Type (Typ)
 239         and then not Rchk
 240       then
 241          Result := Expr;
 242
 243       --  Cases where we end up with a conversion. Note that we do not use the
 244       --  Convert_To abstraction here, since we may be decorating the resulting
 245       --  conversion with Rounded_Result and/or Conversion_OK, so we want the
 246       --  conversion node present, even if it appears to be redundant.
 247
 248       else
 249          --  Remove inner conversion if both inner and outer conversions are
 250          --  to integer types, since the inner one serves no purpose (except
 251          --  perhaps to set rounding, so we preserve the Rounded_Result flag)
 252          --  and also we preserve the range check flag on the inner operand
 253
 254          if Is_Integer_Type (Typ)
 255            and then Is_Integer_Type (Etype (Expr))
 256            and then Nkind (Expr) = N_Type_Conversion
 257          then
 258             Result :=
 259               Make_Type_Conversion (Loc,
 260                 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
 261                 Expression   => Expression (Expr));
 262             Set_Rounded_Result (Result, Rounded_Result_Set (Expr));
 263             Rcheck := Rcheck or Do_Range_Check (Expr);
 264
 265          --  For all other cases, a simple type conversion will work
 266
 267          else
 268             Result :=
 269               Make_Type_Conversion (Loc,
 270                 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
 271                 Expression   => Expr);
 272          end if;
 273
 274          --  Set Conversion_OK if either result or expression type is a
 275          --  fixed-point type, since from a semantic point of view, we are
 276          --  treating fixed-point values as integers at this stage.
 277
 278          if Is_Fixed_Point_Type (Typ)
 279            or else Is_Fixed_Point_Type (Etype (Expression (Result)))
 280          then
 281             Set_Conversion_OK (Result);
 282          end if;
 283
 284          --  Set Do_Range_Check if either it was requested by the caller,
 285          --  or if an eliminated inner conversion had a range check.
 286
 287          if Rcheck then
 288             Enable_Range_Check (Result);
 289          else
 290             Set_Do_Range_Check (Result, False);
 291          end if;
 292       end if;
 293
 294       Set_Etype (Result, Typ);
 295       return Result;
 296    end Build_Conversion;
 297
 298    ------------------
 299    -- Build_Divide --
 300    ------------------
 301
 302    function Build_Divide (N : Node_Id; L, R : Node_Id) return Node_Id is
 303       Loc         : constant Source_Ptr := Sloc (N);
 304       Left_Type   : constant Entity_Id  := Base_Type (Etype (L));
 305       Right_Type  : constant Entity_Id  := Base_Type (Etype (R));
 306       Result_Type : Entity_Id;
 307       Rnode       : Node_Id;
 308
 309    begin
 310       --  Deal with floating-point case first
 311
 312       if Is_Floating_Point_Type (Left_Type) then
 313          pragma Assert (Left_Type = Universal_Real);
 314          pragma Assert (Right_Type = Universal_Real);
 315
 316          Rnode := Make_Op_Divide (Loc, L, R);
 317          Result_Type := Universal_Real;
 318
 319       --  Integer and fixed-point cases
 320
 321       else
 322          --  An optimization. If the right operand is the literal 1, then we
 323          --  can just return the left hand operand. Putting the optimization
 324          --  here allows us to omit the check at the call site.
 325
 326          if Nkind (R) = N_Integer_Literal and then Intval (R) = 1 then
 327             return L;
 328          end if;
 329
 330          --  If left and right types are the same, no conversion needed
 331
 332          if Left_Type = Right_Type then
 333             Result_Type := Left_Type;
 334             Rnode :=
 335               Make_Op_Divide (Loc,
 336                 Left_Opnd  => L,
 337                 Right_Opnd => R);
 338
 339          --  Use left type if it is the larger of the two
 340
 341          elsif Esize (Left_Type) >= Esize (Right_Type) then
 342             Result_Type := Left_Type;
 343             Rnode :=
 344               Make_Op_Divide (Loc,
 345                 Left_Opnd  => L,
 346                 Right_Opnd => Build_Conversion (N, Left_Type, R));
 347
 348          --  Otherwise right type is larger of the two, us it
 349
 350          else
 351             Result_Type := Right_Type;
 352             Rnode :=
 353               Make_Op_Divide (Loc,
 354                 Left_Opnd => Build_Conversion (N, Right_Type, L),
 355                 Right_Opnd => R);
 356          end if;
 357       end if;
 358
 359       --  We now have a divide node built with Result_Type set. First
 360       --  set Etype of result, as required for all Build_xxx routines
 361
 362       Set_Etype (Rnode, Base_Type (Result_Type));
 363
 364       --  Set Treat_Fixed_As_Integer if operation on fixed-point type
 365       --  since this is a literal arithmetic operation, to be performed
 366       --  by Gigi without any consideration of small values.
 367
 368       if Is_Fixed_Point_Type (Result_Type) then
 369          Set_Treat_Fixed_As_Integer (Rnode);
 370       end if;
 371
 372       --  The result is rounded if the target of the operation is decimal
 373       --  and Rounded_Result is set, or if the target of the operation
 374       --  is an integer type.
 375
 376       if Is_Integer_Type (Etype (N))
 377         or else Rounded_Result_Set (N)
 378       then
 379          Set_Rounded_Result (Rnode);
 380       end if;
 381
 382       return Rnode;
 383    end Build_Divide;
 384
 385    -------------------------
 386    -- Build_Double_Divide --
 387    -------------------------
 388
 389    function Build_Double_Divide
 390      (N       : Node_Id;
 391       X, Y, Z : Node_Id) return Node_Id
 392    is
 393       Y_Size : constant Int := UI_To_Int (Esize (Etype (Y)));
 394       Z_Size : constant Int := UI_To_Int (Esize (Etype (Z)));
 395       Expr   : Node_Id;
 396
 397    begin
 398       --  If denominator fits in 64 bits, we can build the operations directly
 399       --  without causing any intermediate overflow, so that's what we do!
 400
 401       if Int'Max (Y_Size, Z_Size) <= 32 then
 402          return
 403            Build_Divide (N, X, Build_Multiply (N, Y, Z));
 404
 405       --  Otherwise we use the runtime routine
 406
 407       --    [Qnn : Interfaces.Integer_64,
 408       --     Rnn : Interfaces.Integer_64;
 409       --     Double_Divide (X, Y, Z, Qnn, Rnn, Round);
 410       --     Qnn]
 411
 412       else
 413          declare
 414             Loc  : constant Source_Ptr := Sloc (N);
 415             Qnn  : Entity_Id;
 416             Rnn  : Entity_Id;
 417             Code : List_Id;
 418
 419             pragma Warnings (Off, Rnn);
 420
 421          begin
 422             Build_Double_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code);
 423             Insert_Actions (N, Code);
 424             Expr := New_Occurrence_Of (Qnn, Loc);
 425
 426             --  Set type of result in case used elsewhere (see note at start)
 427
 428             Set_Etype (Expr, Etype (Qnn));
 429
 430             --  Set result as analyzed (see note at start on build routines)
 431
 432             return Expr;
 433          end;
 434       end if;
 435    end Build_Double_Divide;
 436
 437    ------------------------------
 438    -- Build_Double_Divide_Code --
 439    ------------------------------
 440
 441    --  If the denominator can be computed in 64-bits, we build
 442
 443    --    [Nnn : constant typ := typ (X);
 444    --     Dnn : constant typ := typ (Y) * typ (Z)
 445    --     Qnn : constant typ := Nnn / Dnn;
 446    --     Rnn : constant typ := Nnn / Dnn;
 447
 448    --  If the numerator cannot be computed in 64 bits, we build
 449
 450    --    [Qnn : typ;
 451    --     Rnn : typ;
 452    --     Double_Divide (X, Y, Z, Qnn, Rnn, Round);]
 453
 454    procedure Build_Double_Divide_Code
 455      (N        : Node_Id;
 456       X, Y, Z  : Node_Id;
 457       Qnn, Rnn : out Entity_Id;
 458       Code     : out List_Id)
 459    is
 460       Loc    : constant Source_Ptr := Sloc (N);
 461
 462       X_Size : constant Int := UI_To_Int (Esize (Etype (X)));
 463       Y_Size : constant Int := UI_To_Int (Esize (Etype (Y)));
 464       Z_Size : constant Int := UI_To_Int (Esize (Etype (Z)));
 465
 466       QR_Siz : Int;
 467       QR_Typ : Entity_Id;
 468
 469       Nnn : Entity_Id;
 470       Dnn : Entity_Id;
 471
 472       Quo : Node_Id;
 473       Rnd : Entity_Id;
 474
 475    begin
 476       --  Find type that will allow computation of numerator
 477
 478       QR_Siz := Int'Max (X_Size, 2 * Int'Max (Y_Size, Z_Size));
 479
 480       if QR_Siz <= 16 then
 481          QR_Typ := Standard_Integer_16;
 482       elsif QR_Siz <= 32 then
 483          QR_Typ := Standard_Integer_32;
 484       elsif QR_Siz <= 64 then
 485          QR_Typ := Standard_Integer_64;
 486
 487       --  For more than 64, bits, we use the 64-bit integer defined in
 488       --  Interfaces, so that it can be handled by the runtime routine
 489
 490       else
 491          QR_Typ := RTE (RE_Integer_64);
 492       end if;
 493
 494       --  Define quotient and remainder, and set their Etypes, so
 495       --  that they can be picked up by Build_xxx routines.
 496
 497       Qnn := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
 498       Rnn := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
 499
 500       Set_Etype (Qnn, QR_Typ);
 501       Set_Etype (Rnn, QR_Typ);
 502
 503       --  Case that we can compute the denominator in 64 bits
 504
 505       if QR_Siz <= 64 then
 506
 507          --  Create temporaries for numerator and denominator and set Etypes,
 508          --  so that New_Occurrence_Of picks them up for Build_xxx calls.
 509
 510          Nnn := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
 511          Dnn := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
 512
 513          Set_Etype (Nnn, QR_Typ);
 514          Set_Etype (Dnn, QR_Typ);
 515
 516          Code := New_List (
 517            Make_Object_Declaration (Loc,
 518              Defining_Identifier => Nnn,
 519              Object_Definition   => New_Occurrence_Of (QR_Typ, Loc),
 520              Constant_Present    => True,
 521              Expression => Build_Conversion (N, QR_Typ, X)),
 522
 523            Make_Object_Declaration (Loc,
 524              Defining_Identifier => Dnn,
 525              Object_Definition   => New_Occurrence_Of (QR_Typ, Loc),
 526              Constant_Present    => True,
 527              Expression =>
 528                Build_Multiply (N,
 529                  Build_Conversion (N, QR_Typ, Y),
 530                  Build_Conversion (N, QR_Typ, Z))));
 531
 532          Quo :=
 533            Build_Divide (N,
 534              New_Occurrence_Of (Nnn, Loc),
 535              New_Occurrence_Of (Dnn, Loc));
 536
 537          Set_Rounded_Result (Quo, Rounded_Result_Set (N));
 538
 539          Append_To (Code,
 540            Make_Object_Declaration (Loc,
 541              Defining_Identifier => Qnn,
 542              Object_Definition   => New_Occurrence_Of (QR_Typ, Loc),
 543              Constant_Present    => True,
 544              Expression          => Quo));
 545
 546          Append_To (Code,
 547            Make_Object_Declaration (Loc,
 548              Defining_Identifier => Rnn,
 549              Object_Definition   => New_Occurrence_Of (QR_Typ, Loc),
 550              Constant_Present    => True,
 551              Expression =>
 552                Build_Rem (N,
 553                  New_Occurrence_Of (Nnn, Loc),
 554                  New_Occurrence_Of (Dnn, Loc))));
 555
 556       --  Case where denominator does not fit in 64 bits, so we have to
 557       --  call the runtime routine to compute the quotient and remainder
 558
 559       else
 560          Rnd := Boolean_Literals (Rounded_Result_Set (N));
 561
 562          Code := New_List (
 563            Make_Object_Declaration (Loc,
 564              Defining_Identifier => Qnn,
 565              Object_Definition   => New_Occurrence_Of (QR_Typ, Loc)),
 566
 567            Make_Object_Declaration (Loc,
 568              Defining_Identifier => Rnn,
 569              Object_Definition   => New_Occurrence_Of (QR_Typ, Loc)),
 570
 571            Make_Procedure_Call_Statement (Loc,
 572              Name => New_Occurrence_Of (RTE (RE_Double_Divide), Loc),
 573              Parameter_Associations => New_List (
 574                Build_Conversion (N, QR_Typ, X),
 575                Build_Conversion (N, QR_Typ, Y),
 576                Build_Conversion (N, QR_Typ, Z),
 577                New_Occurrence_Of (Qnn, Loc),
 578                New_Occurrence_Of (Rnn, Loc),
 579                New_Occurrence_Of (Rnd, Loc))));
 580       end if;
 581    end Build_Double_Divide_Code;
 582
 583    --------------------
 584    -- Build_Multiply --
 585    --------------------
 586
 587    function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id is
 588       Loc         : constant Source_Ptr := Sloc (N);
 589       Left_Type   : constant Entity_Id  := Etype (L);
 590       Right_Type  : constant Entity_Id  := Etype (R);
 591       Left_Size   : Int;
 592       Right_Size  : Int;
 593       Rsize       : Int;
 594       Result_Type : Entity_Id;
 595       Rnode       : Node_Id;
 596
 597    begin
 598       --  Deal with floating-point case first
 599
 600       if Is_Floating_Point_Type (Left_Type) then
 601          pragma Assert (Left_Type = Universal_Real);
 602          pragma Assert (Right_Type = Universal_Real);
 603
 604          Result_Type := Universal_Real;
 605          Rnode := Make_Op_Multiply (Loc, L, R);
 606
 607       --  Integer and fixed-point cases
 608
 609       else
 610          --  An optimization. If the right operand is the literal 1, then we
 611          --  can just return the left hand operand. Putting the optimization
 612          --  here allows us to omit the check at the call site. Similarly, if
 613          --  the left operand is the integer 1 we can return the right operand.
 614
 615          if Nkind (R) = N_Integer_Literal and then Intval (R) = 1 then
 616             return L;
 617          elsif Nkind (L) = N_Integer_Literal and then Intval (L) = 1 then
 618             return R;
 619          end if;
 620
 621          --  Otherwise we need to figure out the correct result type size
 622          --  First figure out the effective sizes of the operands. Normally
 623          --  the effective size of an operand is the RM_Size of the operand.
 624          --  But a special case arises with operands whose size is known at
 625          --  compile time. In this case, we can use the actual value of the
 626          --  operand to get its size if it would fit signed in 8 or 16 bits.
 627
 628          Left_Size := UI_To_Int (RM_Size (Left_Type));
 629
 630          if Compile_Time_Known_Value (L) then
 631             declare
 632                Val : constant Uint := Expr_Value (L);
 633             begin
 634                if Val < Int'(2 ** 7) then
 635                   Left_Size := 8;
 636                elsif Val < Int'(2 ** 15) then
 637                   Left_Size := 16;
 638                end if;
 639             end;
 640          end if;
 641
 642          Right_Size := UI_To_Int (RM_Size (Right_Type));
 643
 644          if Compile_Time_Known_Value (R) then
 645             declare
 646                Val : constant Uint := Expr_Value (R);
 647             begin
 648                if Val <= Int'(2 ** 7) then
 649                   Right_Size := 8;
 650                elsif Val <= Int'(2 ** 15) then
 651                   Right_Size := 16;
 652                end if;
 653             end;
 654          end if;
 655
 656          --  Now the result size must be at least twice the longer of
 657          --  the two sizes, to accommodate all possible results.
 658
 659          Rsize := 2 * Int'Max (Left_Size, Right_Size);
 660
 661          if Rsize <= 8 then
 662             Result_Type := Standard_Integer_8;
 663
 664          elsif Rsize <= 16 then
 665             Result_Type := Standard_Integer_16;
 666
 667          elsif Rsize <= 32 then
 668             Result_Type := Standard_Integer_32;
 669
 670          else
 671             Result_Type := Standard_Integer_64;
 672          end if;
 673
 674          Rnode :=
 675             Make_Op_Multiply (Loc,
 676               Left_Opnd  => Build_Conversion (N, Result_Type, L),
 677               Right_Opnd => Build_Conversion (N, Result_Type, R));
 678       end if;
 679
 680       --  We now have a multiply node built with Result_Type set. First
 681       --  set Etype of result, as required for all Build_xxx routines
 682
 683       Set_Etype (Rnode, Base_Type (Result_Type));
 684
 685       --  Set Treat_Fixed_As_Integer if operation on fixed-point type
 686       --  since this is a literal arithmetic operation, to be performed
 687       --  by Gigi without any consideration of small values.
 688
 689       if Is_Fixed_Point_Type (Result_Type) then
 690          Set_Treat_Fixed_As_Integer (Rnode);
 691       end if;
 692
 693       return Rnode;
 694    end Build_Multiply;
 695
 696    ---------------
 697    -- Build_Rem --
 698    ---------------
 699
 700    function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id is
 701       Loc         : constant Source_Ptr := Sloc (N);
 702       Left_Type   : constant Entity_Id  := Etype (L);
 703       Right_Type  : constant Entity_Id  := Etype (R);
 704       Result_Type : Entity_Id;
 705       Rnode       : Node_Id;
 706
 707    begin
 708       if Left_Type = Right_Type then
 709          Result_Type := Left_Type;
 710          Rnode :=
 711            Make_Op_Rem (Loc,
 712              Left_Opnd  => L,
 713              Right_Opnd => R);
 714
 715       --  If left size is larger, we do the remainder operation using the
 716       --  size of the left type (i.e. the larger of the two integer types).
 717
 718       elsif Esize (Left_Type) >= Esize (Right_Type) then
 719          Result_Type := Left_Type;
 720          Rnode :=
 721            Make_Op_Rem (Loc,
 722              Left_Opnd  => L,
 723              Right_Opnd => Build_Conversion (N, Left_Type, R));
 724
 725       --  Similarly, if the right size is larger, we do the remainder
 726       --  operation using the right type.
 727
 728       else
 729          Result_Type := Right_Type;
 730          Rnode :=
 731            Make_Op_Rem (Loc,
 732              Left_Opnd => Build_Conversion (N, Right_Type, L),
 733              Right_Opnd => R);
 734       end if;
 735
 736       --  We now have an N_Op_Rem node built with Result_Type set. First
 737       --  set Etype of result, as required for all Build_xxx routines
 738
 739       Set_Etype (Rnode, Base_Type (Result_Type));
 740
 741       --  Set Treat_Fixed_As_Integer if operation on fixed-point type
 742       --  since this is a literal arithmetic operation, to be performed
 743       --  by Gigi without any consideration of small values.
 744
 745       if Is_Fixed_Point_Type (Result_Type) then
 746          Set_Treat_Fixed_As_Integer (Rnode);
 747       end if;
 748
 749       --  One more check. We did the rem operation using the larger of the
 750       --  two types, which is reasonable. However, in the case where the
 751       --  two types have unequal sizes, it is impossible for the result of
 752       --  a remainder operation to be larger than the smaller of the two
 753       --  types, so we can put a conversion round the result to keep the
 754       --  evolving operation size as small as possible.
 755
 756       if Esize (Left_Type) >= Esize (Right_Type) then
 757          Rnode := Build_Conversion (N, Right_Type, Rnode);
 758       elsif Esize (Right_Type) >= Esize (Left_Type) then
 759          Rnode := Build_Conversion (N, Left_Type, Rnode);
 760       end if;
 761
 762       return Rnode;
 763    end Build_Rem;
 764
 765    -------------------------
 766    -- Build_Scaled_Divide --
 767    -------------------------
 768
 769    function Build_Scaled_Divide
 770      (N       : Node_Id;
 771       X, Y, Z : Node_Id) return Node_Id
 772    is
 773       X_Size : constant Int := UI_To_Int (Esize (Etype (X)));
 774       Y_Size : constant Int := UI_To_Int (Esize (Etype (Y)));
 775       Expr   : Node_Id;
 776
 777    begin
 778       --  If numerator fits in 64 bits, we can build the operations directly
 779       --  without causing any intermediate overflow, so that's what we do!
 780
 781       if Int'Max (X_Size, Y_Size) <= 32 then
 782          return
 783            Build_Divide (N, Build_Multiply (N, X, Y), Z);
 784
 785       --  Otherwise we use the runtime routine
 786
 787       --    [Qnn : Integer_64,
 788       --     Rnn : Integer_64;
 789       --     Scaled_Divide (X, Y, Z, Qnn, Rnn, Round);
 790       --     Qnn]
 791
 792       else
 793          declare
 794             Loc  : constant Source_Ptr := Sloc (N);
 795             Qnn  : Entity_Id;
 796             Rnn  : Entity_Id;
 797             Code : List_Id;
 798
 799             pragma Warnings (Off, Rnn);
 800
 801          begin
 802             Build_Scaled_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code);
 803             Insert_Actions (N, Code);
 804             Expr := New_Occurrence_Of (Qnn, Loc);
 805
 806             --  Set type of result in case used elsewhere (see note at start)
 807
 808             Set_Etype (Expr, Etype (Qnn));
 809             return Expr;
 810          end;
 811       end if;
 812    end Build_Scaled_Divide;
 813
 814    ------------------------------
 815    -- Build_Scaled_Divide_Code --
 816    ------------------------------
 817
 818    --  If the numerator can be computed in 64-bits, we build
 819
 820    --    [Nnn : constant typ := typ (X) * typ (Y);
 821    --     Dnn : constant typ := typ (Z)
 822    --     Qnn : constant typ := Nnn / Dnn;
 823    --     Rnn : constant typ := Nnn / Dnn;
 824
 825    --  If the numerator cannot be computed in 64 bits, we build
 826
 827    --    [Qnn : Interfaces.Integer_64;
 828    --     Rnn : Interfaces.Integer_64;
 829    --     Scaled_Divide (X, Y, Z, Qnn, Rnn, Round);]
 830
 831    procedure Build_Scaled_Divide_Code
 832      (N        : Node_Id;
 833       X, Y, Z  : Node_Id;
 834       Qnn, Rnn : out Entity_Id;
 835       Code     : out List_Id)
 836    is
 837       Loc    : constant Source_Ptr := Sloc (N);
 838
 839       X_Size : constant Int := UI_To_Int (Esize (Etype (X)));
 840       Y_Size : constant Int := UI_To_Int (Esize (Etype (Y)));
 841       Z_Size : constant Int := UI_To_Int (Esize (Etype (Z)));
 842
 843       QR_Siz : Int;
 844       QR_Typ : Entity_Id;
 845
 846       Nnn : Entity_Id;
 847       Dnn : Entity_Id;
 848
 849       Quo : Node_Id;
 850       Rnd : Entity_Id;
 851
 852    begin
 853       --  Find type that will allow computation of numerator
 854
 855       QR_Siz := Int'Max (X_Size, 2 * Int'Max (Y_Size, Z_Size));
 856
 857       if QR_Siz <= 16 then
 858          QR_Typ := Standard_Integer_16;
 859       elsif QR_Siz <= 32 then
 860          QR_Typ := Standard_Integer_32;
 861       elsif QR_Siz <= 64 then
 862          QR_Typ := Standard_Integer_64;
 863
 864       --  For more than 64, bits, we use the 64-bit integer defined in
 865       --  Interfaces, so that it can be handled by the runtime routine
 866
 867       else
 868          QR_Typ := RTE (RE_Integer_64);
 869       end if;
 870
 871       --  Define quotient and remainder, and set their Etypes, so
 872       --  that they can be picked up by Build_xxx routines.
 873
 874       Qnn := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
 875       Rnn := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
 876
 877       Set_Etype (Qnn, QR_Typ);
 878       Set_Etype (Rnn, QR_Typ);
 879
 880       --  Case that we can compute the numerator in 64 bits
 881
 882       if QR_Siz <= 64 then
 883          Nnn := Make_Defining_Identifier (Loc, New_Internal_Name  ('N'));
 884          Dnn := Make_Defining_Identifier (Loc, New_Internal_Name  ('D'));
 885
 886          --  Set Etypes, so that they can be picked up by New_Occurrence_Of
 887
 888          Set_Etype (Nnn, QR_Typ);
 889          Set_Etype (Dnn, QR_Typ);
 890
 891          Code := New_List (
 892            Make_Object_Declaration (Loc,
 893              Defining_Identifier => Nnn,
 894              Object_Definition   => New_Occurrence_Of (QR_Typ, Loc),
 895              Constant_Present    => True,
 896              Expression =>
 897                Build_Multiply (N,
 898                  Build_Conversion (N, QR_Typ, X),
 899                  Build_Conversion (N, QR_Typ, Y))),
 900
 901            Make_Object_Declaration (Loc,
 902              Defining_Identifier => Dnn,
 903              Object_Definition   => New_Occurrence_Of (QR_Typ, Loc),
 904              Constant_Present    => True,
 905              Expression => Build_Conversion (N, QR_Typ, Z)));
 906
 907          Quo :=
 908            Build_Divide (N,
 909              New_Occurrence_Of (Nnn, Loc),
 910              New_Occurrence_Of (Dnn, Loc));
 911
 912          Append_To (Code,
 913            Make_Object_Declaration (Loc,
 914              Defining_Identifier => Qnn,
 915              Object_Definition   => New_Occurrence_Of (QR_Typ, Loc),
 916              Constant_Present    => True,
 917              Expression          => Quo));
 918
 919          Append_To (Code,
 920            Make_Object_Declaration (Loc,
 921              Defining_Identifier => Rnn,
 922              Object_Definition   => New_Occurrence_Of (QR_Typ, Loc),
 923              Constant_Present    => True,
 924              Expression =>
 925                Build_Rem (N,
 926                  New_Occurrence_Of (Nnn, Loc),
 927                  New_Occurrence_Of (Dnn, Loc))));
 928
 929       --  Case where numerator does not fit in 64 bits, so we have to
 930       --  call the runtime routine to compute the quotient and remainder
 931
 932       else
 933          Rnd := Boolean_Literals (Rounded_Result_Set (N));
 934
 935          Code := New_List (
 936            Make_Object_Declaration (Loc,
 937              Defining_Identifier => Qnn,
 938              Object_Definition   => New_Occurrence_Of (QR_Typ, Loc)),
 939
 940            Make_Object_Declaration (Loc,
 941              Defining_Identifier => Rnn,
 942              Object_Definition   => New_Occurrence_Of (QR_Typ, Loc)),
 943
 944            Make_Procedure_Call_Statement (Loc,
 945              Name => New_Occurrence_Of (RTE (RE_Scaled_Divide), Loc),
 946              Parameter_Associations => New_List (
 947                Build_Conversion (N, QR_Typ, X),
 948                Build_Conversion (N, QR_Typ, Y),
 949                Build_Conversion (N, QR_Typ, Z),
 950                New_Occurrence_Of (Qnn, Loc),
 951                New_Occurrence_Of (Rnn, Loc),
 952                New_Occurrence_Of (Rnd, Loc))));
 953       end if;
 954
 955       --  Set type of result, for use in caller
 956
 957       Set_Etype (Qnn, QR_Typ);
 958    end Build_Scaled_Divide_Code;
 959
 960    ---------------------------
 961    -- Do_Divide_Fixed_Fixed --
 962    ---------------------------
 963
 964    --  We have:
 965
 966    --    (Result_Value * Result_Small) =
 967    --        (Left_Value * Left_Small) / (Right_Value * Right_Small)
 968
 969    --    Result_Value = (Left_Value / Right_Value) *
 970    --                   (Left_Small / (Right_Small * Result_Small));
 971
 972    --  we can do the operation in integer arithmetic if this fraction is an
 973    --  integer or the reciprocal of an integer, as detailed in (RM G.2.3(21)).
 974    --  Otherwise the result is in the close result set and our approach is to
 975    --  use floating-point to compute this close result.
 976
 977    procedure Do_Divide_Fixed_Fixed (N : Node_Id) is
 978       Left        : constant Node_Id   := Left_Opnd (N);
 979       Right       : constant Node_Id   := Right_Opnd (N);
 980       Left_Type   : constant Entity_Id := Etype (Left);
 981       Right_Type  : constant Entity_Id := Etype (Right);
 982       Result_Type : constant Entity_Id := Etype (N);
 983       Right_Small : constant Ureal     := Small_Value (Right_Type);
 984       Left_Small  : constant Ureal     := Small_Value (Left_Type);
 985
 986       Result_Small : Ureal;
 987       Frac         : Ureal;
 988       Frac_Num     : Uint;
 989       Frac_Den     : Uint;
 990       Lit_Int      : Node_Id;
 991
 992    begin
 993       --  Rounding is required if the result is integral
 994
 995       if Is_Integer_Type (Result_Type) then
 996          Set_Rounded_Result (N);
 997       end if;
 998
 999       --  Get result small. If the result is an integer, treat it as though
1000       --  it had a small of 1.0, all other processing is identical.
1001
1002       if Is_Integer_Type (Result_Type) then
1003          Result_Small := Ureal_1;
1004       else
1005          Result_Small := Small_Value (Result_Type);
1006       end if;
1007
1008       --  Get small ratio
1009
1010       Frac     := Left_Small / (Right_Small * Result_Small);
1011       Frac_Num := Norm_Num (Frac);
1012       Frac_Den := Norm_Den (Frac);
1013
1014       --  If the fraction is an integer, then we get the result by multiplying
1015       --  the left operand by the integer, and then dividing by the right
1016       --  operand (the order is important, if we did the divide first, we
1017       --  would lose precision).
1018
1019       if Frac_Den = 1 then
1020          Lit_Int := Integer_Literal (N, Frac_Num); -- always positive
1021
1022          if Present (Lit_Int) then
1023             Set_Result (N, Build_Scaled_Divide (N, Left, Lit_Int, Right));
1024             return;
1025          end if;
1026
1027       --  If the fraction is the reciprocal of an integer, then we get the
1028       --  result by first multiplying the divisor by the integer, and then
1029       --  doing the division with the adjusted divisor.
1030
1031       --  Note: this is much better than doing two divisions: multiplications
1032       --  are much faster than divisions (and certainly faster than rounded
1033       --  divisions), and we don't get inaccuracies from double rounding.
1034
1035       elsif Frac_Num = 1 then
1036          Lit_Int := Integer_Literal (N, Frac_Den); -- always positive
1037
1038          if Present (Lit_Int) then
1039             Set_Result (N, Build_Double_Divide (N, Left, Right, Lit_Int));
1040             return;
1041          end if;
1042       end if;
1043
1044       --  If we fall through, we use floating-point to compute the result
1045
1046       Set_Result (N,
1047         Build_Multiply (N,
1048           Build_Divide (N, Fpt_Value (Left), Fpt_Value (Right)),
1049           Real_Literal (N, Frac)));
1050    end Do_Divide_Fixed_Fixed;
1051
1052    -------------------------------
1053    -- Do_Divide_Fixed_Universal --
1054    -------------------------------
1055
1056    --  We have:
1057
1058    --    (Result_Value * Result_Small) = (Left_Value * Left_Small) / Lit_Value;
1059    --    Result_Value = Left_Value * Left_Small /(Lit_Value * Result_Small);
1060
1061    --  The result is required to be in the perfect result set if the literal
1062    --  can be factored so that the resulting small ratio is an integer or the
1063    --  reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed
1064    --  analysis of these RM requirements:
1065
1066    --  We must factor the literal, finding an integer K:
1067
1068    --     Lit_Value = K * Right_Small
1069    --     Right_Small = Lit_Value / K
1070
1071    --  such that the small ratio:
1072
1073    --              Left_Small
1074    --     ------------------------------
1075    --     (Lit_Value / K) * Result_Small
1076
1077    --            Left_Small
1078    --  =  ------------------------  *  K
1079    --     Lit_Value * Result_Small
1080
1081    --  is an integer or the reciprocal of an integer, and for
1082    --  implementation efficiency we need the smallest such K.
1083
1084    --  First we reduce the left fraction to lowest terms
1085
1086    --    If numerator = 1, then for K = 1, the small ratio is the reciprocal
1087    --    of an integer, and this is clearly the minimum K case, so set K = 1,
1088    --    Right_Small = Lit_Value.
1089
1090    --    If numerator > 1, then set K to the denominator of the fraction so
1091    --    that the resulting small ratio is an integer (the numerator value).
1092
1093    procedure Do_Divide_Fixed_Universal (N : Node_Id) is
1094       Left        : constant Node_Id   := Left_Opnd (N);
1095       Right       : constant Node_Id   := Right_Opnd (N);
1096       Left_Type   : constant Entity_Id := Etype (Left);
1097       Result_Type : constant Entity_Id := Etype (N);
1098       Left_Small  : constant Ureal     := Small_Value (Left_Type);
1099       Lit_Value   : constant Ureal     := Realval (Right);
1100
1101       Result_Small : Ureal;
1102       Frac         : Ureal;
1103       Frac_Num     : Uint;
1104       Frac_Den     : Uint;
1105       Lit_K        : Node_Id;
1106       Lit_Int      : Node_Id;
1107
1108    begin
1109       --  Get result small. If the result is an integer, treat it as though
1110       --  it had a small of 1.0, all other processing is identical.
1111
1112       if Is_Integer_Type (Result_Type) then
1113          Result_Small := Ureal_1;
1114       else
1115          Result_Small := Small_Value (Result_Type);
1116       end if;
1117
1118       --  Determine if literal can be rewritten successfully
1119
1120       Frac     := Left_Small / (Lit_Value * Result_Small);
1121       Frac_Num := Norm_Num (Frac);
1122       Frac_Den := Norm_Den (Frac);
1123
1124       --  Case where fraction is the reciprocal of an integer (K = 1, integer
1125       --  = denominator). If this integer is not too large, this is the case
1126       --  where the result can be obtained by dividing by this integer value.
1127
1128       if Frac_Num = 1 then
1129          Lit_Int := Integer_Literal (N, Frac_Den, UR_Is_Negative (Frac));
1130
1131          if Present (Lit_Int) then
1132             Set_Result (N, Build_Divide (N, Left, Lit_Int));
1133             return;
1134          end if;
1135
1136       --  Case where we choose K to make fraction an integer (K = denominator
1137       --  of fraction, integer = numerator of fraction). If both K and the
1138       --  numerator are small enough, this is the case where the result can
1139       --  be obtained by first multiplying by the integer value and then
1140       --  dividing by K (the order is important, if we divided first, we
1141       --  would lose precision).
1142
1143       else
1144          Lit_Int := Integer_Literal (N, Frac_Num, UR_Is_Negative (Frac));
1145          Lit_K   := Integer_Literal (N, Frac_Den, False);
1146
1147          if Present (Lit_Int) and then Present (Lit_K) then
1148             Set_Result (N, Build_Scaled_Divide (N, Left, Lit_Int, Lit_K));
1149             return;
1150          end if;
1151       end if;
1152
1153       --  Fall through if the literal cannot be successfully rewritten, or if
1154       --  the small ratio is out of range of integer arithmetic. In the former
1155       --  case it is fine to use floating-point to get the close result set,
1156       --  and in the latter case, it means that the result is zero or raises
1157       --  constraint error, and we can do that accurately in floating-point.
1158
1159       --  If we end up using floating-point, then we take the right integer
1160       --  to be one, and its small to be the value of the original right real
1161       --  literal. That way, we need only one floating-point multiplication.
1162
1163       Set_Result (N,
1164         Build_Multiply (N, Fpt_Value (Left), Real_Literal (N, Frac)));
1165    end Do_Divide_Fixed_Universal;
1166
1167    -------------------------------
1168    -- Do_Divide_Universal_Fixed --
1169    -------------------------------
1170
1171    --  We have:
1172
1173    --    (Result_Value * Result_Small) =
1174    --          Lit_Value / (Right_Value * Right_Small)
1175    --    Result_Value =
1176    --          (Lit_Value / (Right_Small * Result_Small)) / Right_Value
1177
1178    --  The result is required to be in the perfect result set if the literal
1179    --  can be factored so that the resulting small ratio is an integer or the
1180    --  reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed
1181    --  analysis of these RM requirements:
1182
1183    --  We must factor the literal, finding an integer K:
1184
1185    --     Lit_Value = K * Left_Small
1186    --     Left_Small = Lit_Value / K
1187
1188    --  such that the small ratio:
1189
1190    --           (Lit_Value / K)
1191    --     --------------------------
1192    --     Right_Small * Result_Small
1193
1194    --              Lit_Value             1
1195    --  =  --------------------------  *  -
1196    --     Right_Small * Result_Small     K
1197
1198    --  is an integer or the reciprocal of an integer, and for
1199    --  implementation efficiency we need the smallest such K.
1200
1201    --  First we reduce the left fraction to lowest terms
1202
1203    --    If denominator = 1, then for K = 1, the small ratio is an integer
1204    --    (the numerator) and this is clearly the minimum K case, so set K = 1,
1205    --    and Left_Small = Lit_Value.
1206
1207    --    If denominator > 1, then set K to the numerator of the fraction so
1208    --    that the resulting small ratio is the reciprocal of an integer (the
1209    --    numerator value).
1210
1211    procedure Do_Divide_Universal_Fixed (N : Node_Id) is
1212       Left        : constant Node_Id   := Left_Opnd (N);
1213       Right       : constant Node_Id   := Right_Opnd (N);
1214       Right_Type  : constant Entity_Id := Etype (Right);
1215       Result_Type : constant Entity_Id := Etype (N);
1216       Right_Small : constant Ureal     := Small_Value (Right_Type);
1217       Lit_Value   : constant Ureal     := Realval (Left);
1218
1219       Result_Small : Ureal;
1220       Frac         : Ureal;
1221       Frac_Num     : Uint;
1222       Frac_Den     : Uint;
1223       Lit_K        : Node_Id;
1224       Lit_Int      : Node_Id;
1225
1226    begin
1227       --  Get result small. If the result is an integer, treat it as though
1228       --  it had a small of 1.0, all other processing is identical.
1229
1230       if Is_Integer_Type (Result_Type) then
1231          Result_Small := Ureal_1;
1232       else
1233          Result_Small := Small_Value (Result_Type);
1234       end if;
1235
1236       --  Determine if literal can be rewritten successfully
1237
1238       Frac     := Lit_Value / (Right_Small * Result_Small);
1239       Frac_Num := Norm_Num (Frac);
1240       Frac_Den := Norm_Den (Frac);
1241
1242       --  Case where fraction is an integer (K = 1, integer = numerator). If
1243       --  this integer is not too large, this is the case where the result
1244       --  can be obtained by dividing this integer by the right operand.
1245
1246       if Frac_Den = 1 then
1247          Lit_Int := Integer_Literal (N, Frac_Num, UR_Is_Negative (Frac));
1248
1249          if Present (Lit_Int) then
1250             Set_Result (N, Build_Divide (N, Lit_Int, Right));
1251             return;
1252          end if;
1253
1254       --  Case where we choose K to make the fraction the reciprocal of an
1255       --  integer (K = numerator of fraction, integer = numerator of fraction).
1256       --  If both K and the integer are small enough, this is the case where
1257       --  the result can be obtained by multiplying the right operand by K
1258       --  and then dividing by the integer value. The order of the operations
1259       --  is important (if we divided first, we would lose precision).
1260
1261       else
1262          Lit_Int := Integer_Literal (N, Frac_Den, UR_Is_Negative (Frac));
1263          Lit_K   := Integer_Literal (N, Frac_Num, False);
1264
1265          if Present (Lit_Int) and then Present (Lit_K) then
1266             Set_Result (N, Build_Double_Divide (N, Lit_K, Right, Lit_Int));
1267             return;
1268          end if;
1269       end if;
1270
1271       --  Fall through if the literal cannot be successfully rewritten, or if
1272       --  the small ratio is out of range of integer arithmetic. In the former
1273       --  case it is fine to use floating-point to get the close result set,
1274       --  and in the latter case, it means that the result is zero or raises
1275       --  constraint error, and we can do that accurately in floating-point.
1276
1277       --  If we end up using floating-point, then we take the right integer
1278       --  to be one, and its small to be the value of the original right real
1279       --  literal. That way, we need only one floating-point division.
1280
1281       Set_Result (N,
1282         Build_Divide (N, Real_Literal (N, Frac), Fpt_Value (Right)));
1283    end Do_Divide_Universal_Fixed;
1284
1285    -----------------------------
1286    -- Do_Multiply_Fixed_Fixed --
1287    -----------------------------
1288
1289    --  We have:
1290
1291    --    (Result_Value * Result_Small) =
1292    --        (Left_Value * Left_Small) * (Right_Value * Right_Small)
1293
1294    --    Result_Value = (Left_Value * Right_Value) *
1295    --                   (Left_Small * Right_Small) / Result_Small;
1296
1297    --  we can do the operation in integer arithmetic if this fraction is an
1298    --  integer or the reciprocal of an integer, as detailed in (RM G.2.3(21)).
1299    --  Otherwise the result is in the close result set and our approach is to
1300    --  use floating-point to compute this close result.
1301
1302    procedure Do_Multiply_Fixed_Fixed (N : Node_Id) is
1303       Left  : constant Node_Id := Left_Opnd (N);
1304       Right : constant Node_Id := Right_Opnd (N);
1305
1306       Left_Type   : constant Entity_Id := Etype (Left);
1307       Right_Type  : constant Entity_Id := Etype (Right);
1308       Result_Type : constant Entity_Id := Etype (N);
1309       Right_Small : constant Ureal     := Small_Value (Right_Type);
1310       Left_Small  : constant Ureal     := Small_Value (Left_Type);
1311
1312       Result_Small : Ureal;
1313       Frac         : Ureal;
1314       Frac_Num     : Uint;
1315       Frac_Den     : Uint;
1316       Lit_Int      : Node_Id;
1317
1318    begin
1319       --  Get result small. If the result is an integer, treat it as though
1320       --  it had a small of 1.0, all other processing is identical.
1321
1322       if Is_Integer_Type (Result_Type) then
1323          Result_Small := Ureal_1;
1324       else
1325          Result_Small := Small_Value (Result_Type);
1326       end if;
1327
1328       --  Get small ratio
1329
1330       Frac     := (Left_Small * Right_Small) / Result_Small;
1331       Frac_Num := Norm_Num (Frac);
1332       Frac_Den := Norm_Den (Frac);
1333
1334       --  If the fraction is an integer, then we get the result by multiplying
1335       --  the operands, and then multiplying the result by the integer value.
1336
1337       if Frac_Den = 1 then
1338          Lit_Int := Integer_Literal (N, Frac_Num); -- always positive
1339
1340          if Present (Lit_Int) then
1341             Set_Result (N,
1342               Build_Multiply (N, Build_Multiply (N, Left, Right),
1343                 Lit_Int));
1344             return;
1345          end if;
1346
1347       --  If the fraction is the reciprocal of an integer, then we get the
1348       --  result by multiplying the operands, and then dividing the result by
1349       --  the integer value. The order of the operations is important, if we
1350       --  divided first, we would lose precision.
1351
1352       elsif Frac_Num = 1 then
1353          Lit_Int := Integer_Literal (N, Frac_Den); -- always positive
1354
1355          if Present (Lit_Int) then
1356             Set_Result (N, Build_Scaled_Divide (N, Left, Right, Lit_Int));
1357             return;
1358          end if;
1359       end if;
1360
1361       --  If we fall through, we use floating-point to compute the result
1362
1363       Set_Result (N,
1364         Build_Multiply (N,
1365           Build_Multiply (N, Fpt_Value (Left), Fpt_Value (Right)),
1366           Real_Literal (N, Frac)));
1367    end Do_Multiply_Fixed_Fixed;
1368
1369    ---------------------------------
1370    -- Do_Multiply_Fixed_Universal --
1371    ---------------------------------
1372
1373    --  We have:
1374
1375    --    (Result_Value * Result_Small) = (Left_Value * Left_Small) * Lit_Value;
1376    --    Result_Value = Left_Value * (Left_Small * Lit_Value) / Result_Small;
1377
1378    --  The result is required to be in the perfect result set if the literal
1379    --  can be factored so that the resulting small ratio is an integer or the
1380    --  reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed
1381    --  analysis of these RM requirements:
1382
1383    --  We must factor the literal, finding an integer K:
1384
1385    --     Lit_Value = K * Right_Small
1386    --     Right_Small = Lit_Value / K
1387
1388    --  such that the small ratio:
1389
1390    --     Left_Small * (Lit_Value / K)
1391    --     ----------------------------
1392    --             Result_Small
1393
1394    --     Left_Small * Lit_Value     1
1395    --  =  ----------------------  *  -
1396    --          Result_Small          K
1397
1398    --  is an integer or the reciprocal of an integer, and for
1399    --  implementation efficiency we need the smallest such K.
1400
1401    --  First we reduce the left fraction to lowest terms
1402
1403    --    If denominator = 1, then for K = 1, the small ratio is an integer, and
1404    --    this is clearly the minimum K case, so set
1405
1406    --      K = 1, Right_Small = Lit_Value
1407
1408    --    If denominator > 1, then set K to the numerator of the fraction, so
1409    --    that the resulting small ratio is the reciprocal of the integer (the
1410    --    denominator value).
1411
1412    procedure Do_Multiply_Fixed_Universal
1413      (N           : Node_Id;
1414       Left, Right : Node_Id)
1415    is
1416       Left_Type   : constant Entity_Id := Etype (Left);
1417       Result_Type : constant Entity_Id := Etype (N);
1418       Left_Small  : constant Ureal     := Small_Value (Left_Type);
1419       Lit_Value   : constant Ureal     := Realval (Right);
1420
1421       Result_Small : Ureal;
1422       Frac         : Ureal;
1423       Frac_Num     : Uint;
1424       Frac_Den     : Uint;
1425       Lit_K        : Node_Id;
1426       Lit_Int      : Node_Id;
1427
1428    begin
1429       --  Get result small. If the result is an integer, treat it as though
1430       --  it had a small of 1.0, all other processing is identical.
1431
1432       if Is_Integer_Type (Result_Type) then
1433          Result_Small := Ureal_1;
1434       else
1435          Result_Small := Small_Value (Result_Type);
1436       end if;
1437
1438       --  Determine if literal can be rewritten successfully
1439
1440       Frac     := (Left_Small * Lit_Value) / Result_Small;
1441       Frac_Num := Norm_Num (Frac);
1442       Frac_Den := Norm_Den (Frac);
1443
1444       --  Case where fraction is an integer (K = 1, integer = numerator). If
1445       --  this integer is not too large, this is the case where the result can
1446       --  be obtained by multiplying by this integer value.
1447
1448       if Frac_Den = 1 then
1449          Lit_Int := Integer_Literal (N, Frac_Num, UR_Is_Negative (Frac));
1450
1451          if Present (Lit_Int) then
1452             Set_Result (N, Build_Multiply (N, Left, Lit_Int));
1453             return;
1454          end if;
1455
1456       --  Case where we choose K to make fraction the reciprocal of an integer
1457       --  (K = numerator of fraction, integer = denominator of fraction). If
1458       --  both K and the denominator are small enough, this is the case where
1459       --  the result can be obtained by first multiplying by K, and then
1460       --  dividing by the integer value.
1461
1462       else
1463          Lit_Int := Integer_Literal (N, Frac_Den, UR_Is_Negative (Frac));
1464          Lit_K   := Integer_Literal (N, Frac_Num);
1465
1466          if Present (Lit_Int) and then Present (Lit_K) then
1467             Set_Result (N, Build_Scaled_Divide (N, Left, Lit_K, Lit_Int));
1468             return;
1469          end if;
1470       end if;
1471
1472       --  Fall through if the literal cannot be successfully rewritten, or if
1473       --  the small ratio is out of range of integer arithmetic. In the former
1474       --  case it is fine to use floating-point to get the close result set,
1475       --  and in the latter case, it means that the result is zero or raises
1476       --  constraint error, and we can do that accurately in floating-point.
1477
1478       --  If we end up using floating-point, then we take the right integer
1479       --  to be one, and its small to be the value of the original right real
1480       --  literal. That way, we need only one floating-point multiplication.
1481
1482       Set_Result (N,
1483         Build_Multiply (N, Fpt_Value (Left), Real_Literal (N, Frac)));
1484    end Do_Multiply_Fixed_Universal;
1485
1486    ---------------------------------
1487    -- Expand_Convert_Fixed_Static --
1488    ---------------------------------
1489
1490    procedure Expand_Convert_Fixed_Static (N : Node_Id) is
1491    begin
1492       Rewrite (N,
1493         Convert_To (Etype (N),
1494           Make_Real_Literal (Sloc (N), Expr_Value_R (Expression (N)))));
1495       Analyze_And_Resolve (N);
1496    end Expand_Convert_Fixed_Static;
1497
1498    -----------------------------------
1499    -- Expand_Convert_Fixed_To_Fixed --
1500    -----------------------------------
1501
1502    --  We have:
1503
1504    --    Result_Value * Result_Small = Source_Value * Source_Small
1505    --    Result_Value = Source_Value * (Source_Small / Result_Small)
1506
1507    --  If the small ratio (Source_Small / Result_Small) is a sufficiently small
1508    --  integer, then the perfect result set is obtained by a single integer
1509    --  multiplication.
1510
1511    --  If the small ratio is the reciprocal of a sufficiently small integer,
1512    --  then the perfect result set is obtained by a single integer division.
1513
1514    --  In other cases, we obtain the close result set by calculating the
1515    --  result in floating-point.
1516
1517    procedure Expand_Convert_Fixed_To_Fixed (N : Node_Id) is
1518       Rng_Check   : constant Boolean   := Do_Range_Check (N);
1519       Expr        : constant Node_Id   := Expression (N);
1520       Result_Type : constant Entity_Id := Etype (N);
1521       Source_Type : constant Entity_Id := Etype (Expr);
1522       Small_Ratio : Ureal;
1523       Ratio_Num   : Uint;
1524       Ratio_Den   : Uint;
1525       Lit         : Node_Id;
1526
1527    begin
1528       if Is_OK_Static_Expression (Expr) then
1529          Expand_Convert_Fixed_Static (N);
1530          return;
1531       end if;
1532
1533       Small_Ratio := Small_Value (Source_Type) / Small_Value (Result_Type);
1534       Ratio_Num   := Norm_Num (Small_Ratio);
1535       Ratio_Den   := Norm_Den (Small_Ratio);
1536
1537       if Ratio_Den = 1 then
1538          if Ratio_Num = 1 then
1539             Set_Result (N, Expr);
1540             return;
1541
1542          else
1543             Lit := Integer_Literal (N, Ratio_Num);
1544
1545             if Present (Lit) then
1546                Set_Result (N, Build_Multiply (N, Expr, Lit));
1547                return;
1548             end if;
1549          end if;
1550
1551       elsif Ratio_Num = 1 then
1552          Lit := Integer_Literal (N, Ratio_Den);
1553
1554          if Present (Lit) then
1555             Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check);
1556             return;
1557          end if;
1558       end if;
1559
1560       --  Fall through to use floating-point for the close result set case
1561       --  either as a result of the small ratio not being an integer or the
1562       --  reciprocal of an integer, or if the integer is out of range.
1563
1564       Set_Result (N,
1565         Build_Multiply (N,
1566           Fpt_Value (Expr),
1567           Real_Literal (N, Small_Ratio)),
1568         Rng_Check);
1569    end Expand_Convert_Fixed_To_Fixed;
1570
1571    -----------------------------------
1572    -- Expand_Convert_Fixed_To_Float --
1573    -----------------------------------
1574
1575    --  If the small of the fixed type is 1.0, then we simply convert the
1576    --  integer value directly to the target floating-point type, otherwise
1577    --  we first have to multiply by the small, in Universal_Real, and then
1578    --  convert the result to the target floating-point type.
1579
1580    procedure Expand_Convert_Fixed_To_Float (N : Node_Id) is
1581       Rng_Check   : constant Boolean    := Do_Range_Check (N);
1582       Expr        : constant Node_Id    := Expression (N);
1583       Source_Type : constant Entity_Id  := Etype (Expr);
1584       Small       : constant Ureal      := Small_Value (Source_Type);
1585
1586    begin
1587       if Is_OK_Static_Expression (Expr) then
1588          Expand_Convert_Fixed_Static (N);
1589          return;
1590       end if;
1591
1592       if Small = Ureal_1 then
1593          Set_Result (N, Expr);
1594
1595       else
1596          Set_Result (N,
1597            Build_Multiply (N,
1598              Fpt_Value (Expr),
1599              Real_Literal (N, Small)),
1600            Rng_Check);
1601       end if;
1602    end Expand_Convert_Fixed_To_Float;
1603
1604    -------------------------------------
1605    -- Expand_Convert_Fixed_To_Integer --
1606    -------------------------------------
1607
1608    --  We have:
1609
1610    --    Result_Value = Source_Value * Source_Small
1611
1612    --  If the small value is a sufficiently small integer, then the perfect
1613    --  result set is obtained by a single integer multiplication.
1614
1615    --  If the small value is the reciprocal of a sufficiently small integer,
1616    --  then the perfect result set is obtained by a single integer division.
1617
1618    --  In other cases, we obtain the close result set by calculating the
1619    --  result in floating-point.
1620
1621    procedure Expand_Convert_Fixed_To_Integer (N : Node_Id) is
1622       Rng_Check   : constant Boolean   := Do_Range_Check (N);
1623       Expr        : constant Node_Id   := Expression (N);
1624       Source_Type : constant Entity_Id := Etype (Expr);
1625       Small       : constant Ureal     := Small_Value (Source_Type);
1626       Small_Num   : constant Uint      := Norm_Num (Small);
1627       Small_Den   : constant Uint      := Norm_Den (Small);
1628       Lit         : Node_Id;
1629
1630    begin
1631       if Is_OK_Static_Expression (Expr) then
1632          Expand_Convert_Fixed_Static (N);
1633          return;
1634       end if;
1635
1636       if Small_Den = 1 then
1637          Lit := Integer_Literal (N, Small_Num);
1638
1639          if Present (Lit) then
1640             Set_Result (N, Build_Multiply (N, Expr, Lit), Rng_Check);
1641             return;
1642          end if;
1643
1644       elsif Small_Num = 1 then
1645          Lit := Integer_Literal (N, Small_Den);
1646
1647          if Present (Lit) then
1648             Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check);
1649             return;
1650          end if;
1651       end if;
1652
1653       --  Fall through to use floating-point for the close result set case
1654       --  either as a result of the small value not being an integer or the
1655       --  reciprocal of an integer, or if the integer is out of range.
1656
1657       Set_Result (N,
1658         Build_Multiply (N,
1659           Fpt_Value (Expr),
1660           Real_Literal (N, Small)),
1661         Rng_Check);
1662    end Expand_Convert_Fixed_To_Integer;
1663
1664    -----------------------------------
1665    -- Expand_Convert_Float_To_Fixed --
1666    -----------------------------------
1667
1668    --  We have
1669
1670    --    Result_Value * Result_Small = Operand_Value
1671
1672    --  so compute:
1673
1674    --    Result_Value = Operand_Value * (1.0 / Result_Small)
1675
1676    --  We do the small scaling in floating-point, and we do a multiplication
1677    --  rather than a division, since it is accurate enough for the perfect
1678    --  result cases, and faster.
1679
1680    procedure Expand_Convert_Float_To_Fixed (N : Node_Id) is
1681       Rng_Check   : constant Boolean   := Do_Range_Check (N);
1682       Expr        : constant Node_Id   := Expression (N);
1683       Result_Type : constant Entity_Id := Etype (N);
1684       Small       : constant Ureal     := Small_Value (Result_Type);
1685
1686    begin
1687       --  Optimize small = 1, where we can avoid the multiply completely
1688
1689       if Small = Ureal_1 then
1690          Set_Result (N, Expr, Rng_Check);
1691
1692       --  Normal case where multiply is required
1693
1694       else
1695          Set_Result (N,
1696            Build_Multiply (N,
1697              Fpt_Value (Expr),
1698              Real_Literal (N, Ureal_1 / Small)),
1699            Rng_Check);
1700       end if;
1701    end Expand_Convert_Float_To_Fixed;
1702
1703    -------------------------------------
1704    -- Expand_Convert_Integer_To_Fixed --
1705    -------------------------------------
1706
1707    --  We have
1708
1709    --    Result_Value * Result_Small = Operand_Value
1710    --    Result_Value = Operand_Value / Result_Small
1711
1712    --  If the small value is a sufficiently small integer, then the perfect
1713    --  result set is obtained by a single integer division.
1714
1715    --  If the small value is the reciprocal of a sufficiently small integer,
1716    --  the perfect result set is obtained by a single integer multiplication.
1717
1718    --  In other cases, we obtain the close result set by calculating the
1719    --  result in floating-point using a multiplication by the reciprocal
1720    --  of the Result_Small.
1721
1722    procedure Expand_Convert_Integer_To_Fixed (N : Node_Id) is
1723       Rng_Check   : constant Boolean   := Do_Range_Check (N);
1724       Expr        : constant Node_Id   := Expression (N);
1725       Result_Type : constant Entity_Id := Etype (N);
1726       Small       : constant Ureal     := Small_Value (Result_Type);
1727       Small_Num   : constant Uint      := Norm_Num (Small);
1728       Small_Den   : constant Uint      := Norm_Den (Small);
1729       Lit         : Node_Id;
1730
1731    begin
1732       if Small_Den = 1 then
1733          Lit := Integer_Literal (N, Small_Num);
1734
1735          if Present (Lit) then
1736             Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check);
1737             return;
1738          end if;
1739
1740       elsif Small_Num = 1 then
1741          Lit := Integer_Literal (N, Small_Den);
1742
1743          if Present (Lit) then
1744             Set_Result (N, Build_Multiply (N, Expr, Lit), Rng_Check);
1745             return;
1746          end if;
1747       end if;
1748
1749       --  Fall through to use floating-point for the close result set case
1750       --  either as a result of the small value not being an integer or the
1751       --  reciprocal of an integer, or if the integer is out of range.
1752
1753       Set_Result (N,
1754         Build_Multiply (N,
1755           Fpt_Value (Expr),
1756           Real_Literal (N, Ureal_1 / Small)),
1757         Rng_Check);
1758    end Expand_Convert_Integer_To_Fixed;
1759
1760    --------------------------------
1761    -- Expand_Decimal_Divide_Call --
1762    --------------------------------
1763
1764    --  We have four operands
1765
1766    --    Dividend
1767    --    Divisor
1768    --    Quotient
1769    --    Remainder
1770
1771    --  All of which are decimal types, and which thus have associated
1772    --  decimal scales.
1773
1774    --  Computing the quotient is a similar problem to that faced by the
1775    --  normal fixed-point division, except that it is simpler, because
1776    --  we always have compatible smalls.
1777
1778    --    Quotient = (Dividend / Divisor) * 10**q
1779
1780    --      where 10 ** q = Dividend'Small / (Divisor'Small * Quotient'Small)
1781    --      so q = Divisor'Scale + Quotient'Scale - Dividend'Scale
1782
1783    --    For q >= 0, we compute
1784
1785    --      Numerator   := Dividend * 10 ** q
1786    --      Denominator := Divisor
1787    --      Quotient    := Numerator / Denominator
1788
1789    --    For q < 0, we compute
1790
1791    --      Numerator   := Dividend
1792    --      Denominator := Divisor * 10 ** q
1793    --      Quotient    := Numerator / Denominator
1794
1795    --  Both these divisions are done in truncated mode, and the remainder
1796    --  from these divisions is used to compute the result Remainder. This
1797    --  remainder has the effective scale of the numerator of the division,
1798
1799    --    For q >= 0, the remainder scale is Dividend'Scale + q
1800    --    For q <  0, the remainder scale is Dividend'Scale
1801
1802    --  The result Remainder is then computed by a normal truncating decimal
1803    --  conversion from this scale to the scale of the remainder, i.e. by a
1804    --  division or multiplication by the appropriate power of 10.
1805
1806    procedure Expand_Decimal_Divide_Call (N : Node_Id) is
1807       Loc : constant Source_Ptr := Sloc (N);
1808
1809       Dividend  : Node_Id := First_Actual (N);
1810       Divisor   : Node_Id := Next_Actual (Dividend);
1811       Quotient  : Node_Id := Next_Actual (Divisor);
1812       Remainder : Node_Id := Next_Actual (Quotient);
1813
1814       Dividend_Type   : constant Entity_Id := Etype (Dividend);
1815       Divisor_Type    : constant Entity_Id := Etype (Divisor);
1816       Quotient_Type   : constant Entity_Id := Etype (Quotient);
1817       Remainder_Type  : constant Entity_Id := Etype (Remainder);
1818
1819       Dividend_Scale  : constant Uint := Scale_Value (Dividend_Type);
1820       Divisor_Scale   : constant Uint := Scale_Value (Divisor_Type);
1821       Quotient_Scale  : constant Uint := Scale_Value (Quotient_Type);
1822       Remainder_Scale : constant Uint := Scale_Value (Remainder_Type);
1823
1824       Q                  : Uint;
1825       Numerator_Scale    : Uint;
1826       Stmts              : List_Id;
1827       Qnn                : Entity_Id;
1828       Rnn                : Entity_Id;
1829       Computed_Remainder : Node_Id;
1830       Adjusted_Remainder : Node_Id;
1831       Scale_Adjust       : Uint;
1832
1833    begin
1834       --  Relocate the operands, since they are now list elements, and we
1835       --  need to reference them separately as operands in the expanded code.
1836
1837       Dividend  := Relocate_Node (Dividend);
1838       Divisor   := Relocate_Node (Divisor);
1839       Quotient  := Relocate_Node (Quotient);
1840       Remainder := Relocate_Node (Remainder);
1841
1842       --  Now compute Q, the adjustment scale
1843
1844       Q := Divisor_Scale + Quotient_Scale - Dividend_Scale;
1845
1846       --  If Q is non-negative then we need a scaled divide
1847
1848       if Q >= 0 then
1849          Build_Scaled_Divide_Code
1850            (N,
1851             Dividend,
1852             Integer_Literal (N, Uint_10 ** Q),
1853             Divisor,
1854             Qnn, Rnn, Stmts);
1855
1856          Numerator_Scale := Dividend_Scale + Q;
1857
1858       --  If Q is negative, then we need a double divide
1859
1860       else
1861          Build_Double_Divide_Code
1862            (N,
1863             Dividend,
1864             Divisor,
1865             Integer_Literal (N, Uint_10 ** (-Q)),
1866             Qnn, Rnn, Stmts);
1867
1868          Numerator_Scale := Dividend_Scale;
1869       end if;
1870
1871       --  Add statement to set quotient value
1872
1873       --    Quotient := quotient-type!(Qnn);
1874
1875       Append_To (Stmts,
1876         Make_Assignment_Statement (Loc,
1877           Name => Quotient,
1878           Expression =>
1879             Unchecked_Convert_To (Quotient_Type,
1880               Build_Conversion (N, Quotient_Type,
1881                 New_Occurrence_Of (Qnn, Loc)))));
1882
1883       --  Now we need to deal with computing and setting the remainder. The
1884       --  scale of the remainder is in Numerator_Scale, and the desired
1885       --  scale is the scale of the given Remainder argument. There are
1886       --  three cases:
1887
1888       --    Numerator_Scale > Remainder_Scale
1889
1890       --      in this case, there are extra digits in the computed remainder
1891       --      which must be eliminated by an extra division:
1892
1893       --        computed-remainder := Numerator rem Denominator
1894       --        scale_adjust = Numerator_Scale - Remainder_Scale
1895       --        adjusted-remainder := computed-remainder / 10 ** scale_adjust
1896
1897       --    Numerator_Scale = Remainder_Scale
1898
1899       --      in this case, the we have the remainder we need
1900
1901       --        computed-remainder := Numerator rem Denominator
1902       --        adjusted-remainder := computed-remainder
1903
1904       --    Numerator_Scale < Remainder_Scale
1905
1906       --      in this case, we have insufficient digits in the computed
1907       --      remainder, which must be eliminated by an extra multiply
1908
1909       --        computed-remainder := Numerator rem Denominator
1910       --        scale_adjust = Remainder_Scale - Numerator_Scale
1911       --        adjusted-remainder := computed-remainder * 10 ** scale_adjust
1912
1913       --  Finally we assign the adjusted-remainder to the result Remainder
1914       --  with conversions to get the proper fixed-point type representation.
1915
1916       Computed_Remainder := New_Occurrence_Of (Rnn, Loc);
1917
1918       if Numerator_Scale > Remainder_Scale then
1919          Scale_Adjust := Numerator_Scale - Remainder_Scale;
1920          Adjusted_Remainder :=
1921            Build_Divide
1922              (N, Computed_Remainder, Integer_Literal (N, 10 ** Scale_Adjust));
1923
1924       elsif Numerator_Scale = Remainder_Scale then
1925          Adjusted_Remainder := Computed_Remainder;
1926
1927       else -- Numerator_Scale < Remainder_Scale
1928          Scale_Adjust := Remainder_Scale - Numerator_Scale;
1929          Adjusted_Remainder :=
1930            Build_Multiply
1931              (N, Computed_Remainder, Integer_Literal (N, 10 ** Scale_Adjust));
1932       end if;
1933
1934       --  Assignment of remainder result
1935
1936       Append_To (Stmts,
1937         Make_Assignment_Statement (Loc,
1938           Name => Remainder,
1939           Expression =>
1940             Unchecked_Convert_To (Remainder_Type, Adjusted_Remainder)));
1941
1942       --  Final step is to rewrite the call with a block containing the
1943       --  above sequence of constructed statements for the divide operation.
1944
1945       Rewrite (N,
1946         Make_Block_Statement (Loc,
1947           Handled_Statement_Sequence =>
1948             Make_Handled_Sequence_Of_Statements (Loc,
1949               Statements => Stmts)));
1950
1951       Analyze (N);
1952    end Expand_Decimal_Divide_Call;
1953
1954    -----------------------------------------------
1955    -- Expand_Divide_Fixed_By_Fixed_Giving_Fixed --
1956    -----------------------------------------------
1957
1958    procedure Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N : Node_Id) is
1959       Left  : constant Node_Id := Left_Opnd (N);
1960       Right : constant Node_Id := Right_Opnd (N);
1961
1962    begin
1963       --  Suppress expansion of a fixed-by-fixed division if the
1964       --  operation is supported directly by the target.
1965
1966       if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then
1967          return;
1968       end if;
1969
1970       if Etype (Left) = Universal_Real then
1971          Do_Divide_Universal_Fixed (N);
1972
1973       elsif Etype (Right) = Universal_Real then
1974          Do_Divide_Fixed_Universal (N);
1975
1976       else
1977          Do_Divide_Fixed_Fixed (N);
1978       end if;
1979    end Expand_Divide_Fixed_By_Fixed_Giving_Fixed;
1980
1981    -----------------------------------------------
1982    -- Expand_Divide_Fixed_By_Fixed_Giving_Float --
1983    -----------------------------------------------
1984
1985    --  The division is done in Universal_Real, and the result is multiplied
1986    --  by the small ratio, which is Small (Right) / Small (Left). Special
1987    --  treatment is required for universal operands, which represent their
1988    --  own value and do not require conversion.
1989
1990    procedure Expand_Divide_Fixed_By_Fixed_Giving_Float (N : Node_Id) is
1991       Left  : constant Node_Id := Left_Opnd (N);
1992       Right : constant Node_Id := Right_Opnd (N);
1993
1994       Left_Type  : constant Entity_Id := Etype (Left);
1995       Right_Type : constant Entity_Id := Etype (Right);
1996
1997    begin
1998       --  Case of left operand is universal real, the result we want is:
1999
2000       --    Left_Value / (Right_Value * Right_Small)
2001
2002       --  so we compute this as:
2003
2004       --    (Left_Value / Right_Small) / Right_Value
2005
2006       if Left_Type = Universal_Real then
2007          Set_Result (N,
2008            Build_Divide (N,
2009              Real_Literal (N, Realval (Left) / Small_Value (Right_Type)),
2010              Fpt_Value (Right)));
2011
2012       --  Case of right operand is universal real, the result we want is
2013
2014       --    (Left_Value * Left_Small) / Right_Value
2015
2016       --  so we compute this as:
2017
2018       --    Left_Value * (Left_Small / Right_Value)
2019
2020       --  Note we invert to a multiplication since usually floating-point
2021       --  multiplication is much faster than floating-point division.
2022
2023       elsif Right_Type = Universal_Real then
2024          Set_Result (N,
2025            Build_Multiply (N,
2026              Fpt_Value (Left),
2027              Real_Literal (N, Small_Value (Left_Type) / Realval (Right))));
2028
2029       --  Both operands are fixed, so the value we want is
2030
2031       --    (Left_Value * Left_Small) / (Right_Value * Right_Small)
2032
2033       --  which we compute as:
2034
2035       --    (Left_Value / Right_Value) * (Left_Small / Right_Small)
2036
2037       else
2038          Set_Result (N,
2039            Build_Multiply (N,
2040              Build_Divide (N, Fpt_Value (Left), Fpt_Value (Right)),
2041              Real_Literal (N,
2042                Small_Value (Left_Type) / Small_Value (Right_Type))));
2043       end if;
2044    end Expand_Divide_Fixed_By_Fixed_Giving_Float;
2045
2046    -------------------------------------------------
2047    -- Expand_Divide_Fixed_By_Fixed_Giving_Integer --
2048    -------------------------------------------------
2049
2050    procedure Expand_Divide_Fixed_By_Fixed_Giving_Integer (N : Node_Id) is
2051       Left  : constant Node_Id := Left_Opnd (N);
2052       Right : constant Node_Id := Right_Opnd (N);
2053    begin
2054       if Etype (Left) = Universal_Real then
2055          Do_Divide_Universal_Fixed (N);
2056       elsif Etype (Right) = Universal_Real then
2057          Do_Divide_Fixed_Universal (N);
2058       else
2059          Do_Divide_Fixed_Fixed (N);
2060       end if;
2061    end Expand_Divide_Fixed_By_Fixed_Giving_Integer;
2062
2063    -------------------------------------------------
2064    -- Expand_Divide_Fixed_By_Integer_Giving_Fixed --
2065    -------------------------------------------------
2066
2067    --  Since the operand and result fixed-point type is the same, this is
2068    --  a straight divide by the right operand, the small can be ignored.
2069
2070    procedure Expand_Divide_Fixed_By_Integer_Giving_Fixed (N : Node_Id) is
2071       Left  : constant Node_Id := Left_Opnd (N);
2072       Right : constant Node_Id := Right_Opnd (N);
2073    begin
2074       Set_Result (N, Build_Divide (N, Left, Right));
2075    end Expand_Divide_Fixed_By_Integer_Giving_Fixed;
2076
2077    -------------------------------------------------
2078    -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed --
2079    -------------------------------------------------
2080
2081    procedure Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N : Node_Id) is
2082       Left  : constant Node_Id := Left_Opnd (N);
2083       Right : constant Node_Id := Right_Opnd (N);
2084
2085       procedure Rewrite_Non_Static_Universal (Opnd : Node_Id);
2086       --  The operand may be a non-static universal value, such an
2087       --  exponentiation with a non-static exponent. In that case, treat
2088       --  as a fixed * fixed multiplication, and convert the argument to
2089       --  the target fixed type.
2090
2091       ----------------------------------
2092       -- Rewrite_Non_Static_Universal --
2093       ----------------------------------
2094
2095       procedure Rewrite_Non_Static_Universal (Opnd : Node_Id) is
2096          Loc : constant Source_Ptr := Sloc (N);
2097       begin
2098          Rewrite (Opnd,
2099            Make_Type_Conversion (Loc,
2100              Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
2101              Expression   => Expression (Opnd)));
2102          Analyze_And_Resolve (Opnd, Etype (N));
2103       end Rewrite_Non_Static_Universal;
2104
2105    --  Start of processing for Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
2106
2107    begin
2108       --  Suppress expansion of a fixed-by-fixed multiplication if the
2109       --  operation is supported directly by the target.
2110
2111       if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then
2112          return;
2113       end if;
2114
2115       if Etype (Left) = Universal_Real then
2116          if Nkind (Left) = N_Real_Literal then
2117             Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left);
2118
2119          elsif Nkind (Left) = N_Type_Conversion then
2120             Rewrite_Non_Static_Universal (Left);
2121             Do_Multiply_Fixed_Fixed (N);
2122          end if;
2123
2124       elsif Etype (Right) = Universal_Real then
2125          if Nkind (Right) = N_Real_Literal then
2126             Do_Multiply_Fixed_Universal (N, Left, Right);
2127
2128          elsif Nkind (Right) = N_Type_Conversion then
2129             Rewrite_Non_Static_Universal (Right);
2130             Do_Multiply_Fixed_Fixed (N);
2131          end if;
2132
2133       else
2134          Do_Multiply_Fixed_Fixed (N);
2135       end if;
2136    end Expand_Multiply_Fixed_By_Fixed_Giving_Fixed;
2137
2138    -------------------------------------------------
2139    -- Expand_Multiply_Fixed_By_Fixed_Giving_Float --
2140    -------------------------------------------------
2141
2142    --  The multiply is done in Universal_Real, and the result is multiplied
2143    --  by the adjustment for the smalls which is Small (Right) * Small (Left).
2144    --  Special treatment is required for universal operands.
2145
2146    procedure Expand_Multiply_Fixed_By_Fixed_Giving_Float (N : Node_Id) is
2147       Left  : constant Node_Id := Left_Opnd (N);
2148       Right : constant Node_Id := Right_Opnd (N);
2149
2150       Left_Type  : constant Entity_Id := Etype (Left);
2151       Right_Type : constant Entity_Id := Etype (Right);
2152
2153    begin
2154       --  Case of left operand is universal real, the result we want is
2155
2156       --    Left_Value * (Right_Value * Right_Small)
2157
2158       --  so we compute this as:
2159
2160       --    (Left_Value * Right_Small) * Right_Value;
2161
2162       if Left_Type = Universal_Real then
2163          Set_Result (N,
2164            Build_Multiply (N,
2165              Real_Literal (N, Realval (Left) * Small_Value (Right_Type)),
2166              Fpt_Value (Right)));
2167
2168       --  Case of right operand is universal real, the result we want is
2169
2170       --    (Left_Value * Left_Small) * Right_Value
2171
2172       --  so we compute this as:
2173
2174       --    Left_Value * (Left_Small * Right_Value)
2175
2176       elsif Right_Type = Universal_Real then
2177          Set_Result (N,
2178            Build_Multiply (N,
2179              Fpt_Value (Left),
2180              Real_Literal (N, Small_Value (Left_Type) * Realval (Right))));
2181
2182       --  Both operands are fixed, so the value we want is
2183
2184       --    (Left_Value * Left_Small) * (Right_Value * Right_Small)
2185
2186       --  which we compute as:
2187
2188       --    (Left_Value * Right_Value) * (Right_Small * Left_Small)
2189
2190       else
2191          Set_Result (N,
2192            Build_Multiply (N,
2193              Build_Multiply (N, Fpt_Value (Left), Fpt_Value (Right)),
2194              Real_Literal (N,
2195                Small_Value (Right_Type) * Small_Value (Left_Type))));
2196       end if;
2197    end Expand_Multiply_Fixed_By_Fixed_Giving_Float;
2198
2199    ---------------------------------------------------
2200    -- Expand_Multiply_Fixed_By_Fixed_Giving_Integer --
2201    ---------------------------------------------------
2202
2203    procedure Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N : Node_Id) is
2204       Left  : constant Node_Id := Left_Opnd (N);
2205       Right : constant Node_Id := Right_Opnd (N);
2206    begin
2207       if Etype (Left) = Universal_Real then
2208          Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left);
2209       elsif Etype (Right) = Universal_Real then
2210          Do_Multiply_Fixed_Universal (N, Left, Right);
2211       else
2212          Do_Multiply_Fixed_Fixed (N);
2213       end if;
2214    end Expand_Multiply_Fixed_By_Fixed_Giving_Integer;
2215
2216    ---------------------------------------------------
2217    -- Expand_Multiply_Fixed_By_Integer_Giving_Fixed --
2218    ---------------------------------------------------
2219
2220    --  Since the operand and result fixed-point type is the same, this is
2221    --  a straight multiply by the right operand, the small can be ignored.
2222
2223    procedure Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N : Node_Id) is
2224    begin
2225       Set_Result (N,
2226         Build_Multiply (N, Left_Opnd (N), Right_Opnd (N)));
2227    end Expand_Multiply_Fixed_By_Integer_Giving_Fixed;
2228
2229    ---------------------------------------------------
2230    -- Expand_Multiply_Integer_By_Fixed_Giving_Fixed --
2231    ---------------------------------------------------
2232
2233    --  Since the operand and result fixed-point type is the same, this is
2234    --  a straight multiply by the right operand, the small can be ignored.
2235
2236    procedure Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N : Node_Id) is
2237    begin
2238       Set_Result (N,
2239         Build_Multiply (N, Left_Opnd (N), Right_Opnd (N)));
2240    end Expand_Multiply_Integer_By_Fixed_Giving_Fixed;
2241
2242    ---------------
2243    -- Fpt_Value --
2244    ---------------
2245
2246    function Fpt_Value (N : Node_Id) return Node_Id is
2247       Typ   : constant Entity_Id  := Etype (N);
2248
2249    begin
2250       if Is_Integer_Type (Typ)
2251         or else Is_Floating_Point_Type (Typ)
2252       then
2253          return Build_Conversion (N, Universal_Real, N);
2254
2255       --  Fixed-point case, must get integer value first
2256
2257       else
2258          return Build_Conversion (N, Universal_Real, N);
2259       end if;
2260    end Fpt_Value;
2261
2262    ---------------------
2263    -- Integer_Literal --
2264    ---------------------
2265
2266    function Integer_Literal
2267      (N        : Node_Id;
2268       V        : Uint;
2269       Negative : Boolean := False) return Node_Id
2270    is
2271       T : Entity_Id;
2272       L : Node_Id;
2273
2274    begin
2275       if V < Uint_2 ** 7 then
2276          T := Standard_Integer_8;
2277
2278       elsif V < Uint_2 ** 15 then
2279          T := Standard_Integer_16;
2280
2281       elsif V < Uint_2 ** 31 then
2282          T := Standard_Integer_32;
2283
2284       elsif V < Uint_2 ** 63 then
2285          T := Standard_Integer_64;
2286
2287       else
2288          return Empty;
2289       end if;
2290
2291       if Negative then
2292          L := Make_Integer_Literal (Sloc (N), UI_Negate (V));
2293       else
2294          L := Make_Integer_Literal (Sloc (N), V);
2295       end if;
2296
2297       --  Set type of result in case used elsewhere (see note at start)
2298
2299       Set_Etype (L, T);
2300       Set_Is_Static_Expression (L);
2301
2302       --  We really need to set Analyzed here because we may be creating a
2303       --  very strange beast, namely an integer literal typed as fixed-point
2304       --  and the analyzer won't like that. Probably we should allow the
2305       --  Treat_Fixed_As_Integer flag to appear on integer literal nodes
2306       --  and teach the analyzer how to handle them ???
2307
2308       Set_Analyzed (L);
2309       return L;
2310    end Integer_Literal;
2311
2312    ------------------
2313    -- Real_Literal --
2314    ------------------
2315
2316    function Real_Literal (N : Node_Id; V : Ureal) return Node_Id is
2317       L : Node_Id;
2318
2319    begin
2320       L := Make_Real_Literal (Sloc (N), V);
2321
2322       --  Set type of result in case used elsewhere (see note at start)
2323
2324       Set_Etype (L, Universal_Real);
2325       return L;
2326    end Real_Literal;
2327
2328    ------------------------
2329    -- Rounded_Result_Set --
2330    ------------------------
2331
2332    function Rounded_Result_Set (N : Node_Id) return Boolean is
2333       K : constant Node_Kind := Nkind (N);
2334    begin
2335       if (K = N_Type_Conversion or else
2336           K = N_Op_Divide       or else
2337           K = N_Op_Multiply)
2338         and then
2339           (Rounded_Result (N) or else Is_Integer_Type (Etype (N)))
2340       then
2341          return True;
2342       else
2343          return False;
2344       end if;
2345    end Rounded_Result_Set;
2346
2347    ----------------
2348    -- Set_Result --
2349    ----------------
2350
2351    procedure Set_Result
2352      (N    : Node_Id;
2353       Expr : Node_Id;
2354       Rchk : Boolean := False)
2355    is
2356       Cnode : Node_Id;
2357
2358       Expr_Type   : constant Entity_Id := Etype (Expr);
2359       Result_Type : constant Entity_Id := Etype (N);
2360
2361    begin
2362       --  No conversion required if types match and no range check
2363
2364       if Result_Type = Expr_Type and then not Rchk then
2365          Cnode := Expr;
2366
2367       --  Else perform required conversion
2368
2369       else
2370          Cnode := Build_Conversion (N, Result_Type, Expr, Rchk);
2371       end if;
2372
2373       Rewrite (N, Cnode);
2374       Analyze_And_Resolve (N, Result_Type);
2375    end Set_Result;
2376
2377 end Exp_Fixd;