Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/exp_fixd.adb @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/ada/exp_fixd.adb Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,2464 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ F I X D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Exp_Util; use Exp_Util; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body Exp_Fixd is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- General note; in this unit, a number of routines are driven by the + -- types (Etype) of their operands. Since we are dealing with unanalyzed + -- expressions as they are constructed, the Etypes would not normally be + -- set, but the construction routines that we use in this unit do in fact + -- set the Etype values correctly. In addition, setting the Etype ensures + -- that the analyzer does not try to redetermine the type when the node + -- is analyzed (which would be wrong, since in the case where we set the + -- Treat_Fixed_As_Integer or Conversion_OK flags, it would think it was + -- still dealing with a normal fixed-point operation and mess it up). + + function Build_Conversion + (N : Node_Id; + Typ : Entity_Id; + Expr : Node_Id; + Rchk : Boolean := False; + Trunc : Boolean := False) return Node_Id; + -- Build an expression that converts the expression Expr to type Typ, + -- taking the source location from Sloc (N). If the conversions involve + -- fixed-point types, then the Conversion_OK flag will be set so that the + -- resulting conversions do not get re-expanded. On return the resulting + -- node has its Etype set. If Rchk is set, then Do_Range_Check is set + -- in the resulting conversion node. If Trunc is set, then the + -- Float_Truncate flag is set on the conversion, which must be from + -- a floating-point type to an integer type. + + function Build_Divide (N : Node_Id; L, R : Node_Id) return Node_Id; + -- Builds an N_Op_Divide node from the given left and right operand + -- expressions, using the source location from Sloc (N). The operands are + -- either both Universal_Real, in which case Build_Divide differs from + -- Make_Op_Divide only in that the Etype of the resulting node is set (to + -- Universal_Real), or they can be integer types. In this case the integer + -- types need not be the same, and Build_Divide converts the operand with + -- the smaller sized type to match the type of the other operand and sets + -- this as the result type. The Rounded_Result flag of the result in this + -- case is set from the Rounded_Result flag of node N. On return, the + -- resulting node is analyzed, and has its Etype set. + + function Build_Double_Divide + (N : Node_Id; + X, Y, Z : Node_Id) return Node_Id; + -- Returns a node corresponding to the value X/(Y*Z) using the source + -- location from Sloc (N). The division is rounded if the Rounded_Result + -- flag of N is set. The integer types of X, Y, Z may be different. On + -- return the resulting node is analyzed, and has its Etype set. + + procedure Build_Double_Divide_Code + (N : Node_Id; + X, Y, Z : Node_Id; + Qnn, Rnn : out Entity_Id; + Code : out List_Id); + -- Generates a sequence of code for determining the quotient and remainder + -- of the division X/(Y*Z), using the source location from Sloc (N). + -- Entities of appropriate types are allocated for the quotient and + -- remainder and returned in Qnn and Rnn. The result is rounded if the + -- Rounded_Result flag of N is set. The Etype fields of Qnn and Rnn are + -- appropriately set on return. + + function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id; + -- Builds an N_Op_Multiply node from the given left and right operand + -- expressions, using the source location from Sloc (N). The operands are + -- either both Universal_Real, in which case Build_Multiply differs from + -- Make_Op_Multiply only in that the Etype of the resulting node is set (to + -- Universal_Real), or they can be integer types. In this case the integer + -- types need not be the same, and Build_Multiply chooses a type long + -- enough to hold the product (i.e. twice the size of the longer of the two + -- operand types), and both operands are converted to this type. The Etype + -- of the result is also set to this value. However, the result can never + -- overflow Integer_64, so this is the largest type that is ever generated. + -- On return, the resulting node is analyzed and has its Etype set. + + function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id; + -- Builds an N_Op_Rem node from the given left and right operand + -- expressions, using the source location from Sloc (N). The operands are + -- both integer types, which need not be the same. Build_Rem converts the + -- operand with the smaller sized type to match the type of the other + -- operand and sets this as the result type. The result is never rounded + -- (rem operations cannot be rounded in any case). On return, the resulting + -- node is analyzed and has its Etype set. + + function Build_Scaled_Divide + (N : Node_Id; + X, Y, Z : Node_Id) return Node_Id; + -- Returns a node corresponding to the value X*Y/Z using the source + -- location from Sloc (N). The division is rounded if the Rounded_Result + -- flag of N is set. The integer types of X, Y, Z may be different. On + -- return the resulting node is analyzed and has is Etype set. + + procedure Build_Scaled_Divide_Code + (N : Node_Id; + X, Y, Z : Node_Id; + Qnn, Rnn : out Entity_Id; + Code : out List_Id); + -- Generates a sequence of code for determining the quotient and remainder + -- of the division X*Y/Z, using the source location from Sloc (N). Entities + -- of appropriate types are allocated for the quotient and remainder and + -- returned in Qnn and Rrr. The integer types for X, Y, Z may be different. + -- The division is rounded if the Rounded_Result flag of N is set. The + -- Etype fields of Qnn and Rnn are appropriately set on return. + + procedure Do_Divide_Fixed_Fixed (N : Node_Id); + -- Handles expansion of divide for case of two fixed-point operands + -- (neither of them universal), with an integer or fixed-point result. + -- N is the N_Op_Divide node to be expanded. + + procedure Do_Divide_Fixed_Universal (N : Node_Id); + -- Handles expansion of divide for case of a fixed-point operand divided + -- by a universal real operand, with an integer or fixed-point result. N + -- is the N_Op_Divide node to be expanded. + + procedure Do_Divide_Universal_Fixed (N : Node_Id); + -- Handles expansion of divide for case of a universal real operand + -- divided by a fixed-point operand, with an integer or fixed-point + -- result. N is the N_Op_Divide node to be expanded. + + procedure Do_Multiply_Fixed_Fixed (N : Node_Id); + -- Handles expansion of multiply for case of two fixed-point operands + -- (neither of them universal), with an integer or fixed-point result. + -- N is the N_Op_Multiply node to be expanded. + + procedure Do_Multiply_Fixed_Universal (N : Node_Id; Left, Right : Node_Id); + -- Handles expansion of multiply for case of a fixed-point operand + -- multiplied by a universal real operand, with an integer or fixed- + -- point result. N is the N_Op_Multiply node to be expanded, and + -- Left, Right are the operands (which may have been switched). + + procedure Expand_Convert_Fixed_Static (N : Node_Id); + -- This routine is called where the node N is a conversion of a literal + -- or other static expression of a fixed-point type to some other type. + -- In such cases, we simply rewrite the operand as a real literal and + -- reanalyze. This avoids problems which would otherwise result from + -- attempting to build and fold expressions involving constants. + + function Fpt_Value (N : Node_Id) return Node_Id; + -- Given an operand of fixed-point operation, return an expression that + -- represents the corresponding Universal_Real value. The expression + -- can be of integer type, floating-point type, or fixed-point type. + -- The expression returned is neither analyzed and resolved. The Etype + -- of the result is properly set (to Universal_Real). + + function Integer_Literal + (N : Node_Id; + V : Uint; + Negative : Boolean := False) return Node_Id; + -- Given a non-negative universal integer value, build a typed integer + -- literal node, using the smallest applicable standard integer type. If + -- and only if Negative is true a negative literal is built. If V exceeds + -- 2**63-1, the largest value allowed for perfect result set scaling + -- factors (see RM G.2.3(22)), then Empty is returned. The node N provides + -- the Sloc value for the constructed literal. The Etype of the resulting + -- literal is correctly set, and it is marked as analyzed. + + function Real_Literal (N : Node_Id; V : Ureal) return Node_Id; + -- Build a real literal node from the given value, the Etype of the + -- returned node is set to Universal_Real, since all floating-point + -- arithmetic operations that we construct use Universal_Real + + function Rounded_Result_Set (N : Node_Id) return Boolean; + -- Returns True if N is a node that contains the Rounded_Result flag + -- and if the flag is true or the target type is an integer type. + + procedure Set_Result + (N : Node_Id; + Expr : Node_Id; + Rchk : Boolean := False; + Trunc : Boolean := False); + -- N is the node for the current conversion, division or multiplication + -- operation, and Expr is an expression representing the result. Expr may + -- be of floating-point or integer type. If the operation result is fixed- + -- point, then the value of Expr is in units of small of the result type + -- (i.e. small's have already been dealt with). The result of the call is + -- to replace N by an appropriate conversion to the result type, dealing + -- with rounding for the decimal types case. The node is then analyzed and + -- resolved using the result type. If Rchk or Trunc are True, then + -- respectively Do_Range_Check and Float_Truncate are set in the + -- resulting conversion. + + ---------------------- + -- Build_Conversion -- + ---------------------- + + function Build_Conversion + (N : Node_Id; + Typ : Entity_Id; + Expr : Node_Id; + Rchk : Boolean := False; + Trunc : Boolean := False) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Result : Node_Id; + Rcheck : Boolean := Rchk; + + begin + -- A special case, if the expression is an integer literal and the + -- target type is an integer type, then just retype the integer + -- literal to the desired target type. Don't do this if we need + -- a range check. + + if Nkind (Expr) = N_Integer_Literal + and then Is_Integer_Type (Typ) + and then not Rchk + then + Result := Expr; + + -- Cases where we end up with a conversion. Note that we do not use the + -- Convert_To abstraction here, since we may be decorating the resulting + -- conversion with Rounded_Result and/or Conversion_OK, so we want the + -- conversion node present, even if it appears to be redundant. + + else + -- Remove inner conversion if both inner and outer conversions are + -- to integer types, since the inner one serves no purpose (except + -- perhaps to set rounding, so we preserve the Rounded_Result flag) + -- and also we preserve the range check flag on the inner operand + + if Is_Integer_Type (Typ) + and then Is_Integer_Type (Etype (Expr)) + and then Nkind (Expr) = N_Type_Conversion + then + Result := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Expression (Expr)); + Set_Rounded_Result (Result, Rounded_Result_Set (Expr)); + Rcheck := Rcheck or Do_Range_Check (Expr); + + -- For all other cases, a simple type conversion will work + + else + Result := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Expr); + + Set_Float_Truncate (Result, Trunc); + end if; + + -- Set Conversion_OK if either result or expression type is a + -- fixed-point type, since from a semantic point of view, we are + -- treating fixed-point values as integers at this stage. + + if Is_Fixed_Point_Type (Typ) + or else Is_Fixed_Point_Type (Etype (Expression (Result))) + then + Set_Conversion_OK (Result); + end if; + + -- Set Do_Range_Check if either it was requested by the caller, + -- or if an eliminated inner conversion had a range check. + + if Rcheck then + Enable_Range_Check (Result); + else + Set_Do_Range_Check (Result, False); + end if; + end if; + + Set_Etype (Result, Typ); + return Result; + end Build_Conversion; + + ------------------ + -- Build_Divide -- + ------------------ + + function Build_Divide (N : Node_Id; L, R : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Left_Type : constant Entity_Id := Base_Type (Etype (L)); + Right_Type : constant Entity_Id := Base_Type (Etype (R)); + Result_Type : Entity_Id; + Rnode : Node_Id; + + begin + -- Deal with floating-point case first + + if Is_Floating_Point_Type (Left_Type) then + pragma Assert (Left_Type = Universal_Real); + pragma Assert (Right_Type = Universal_Real); + + Rnode := Make_Op_Divide (Loc, L, R); + Result_Type := Universal_Real; + + -- Integer and fixed-point cases + + else + -- An optimization. If the right operand is the literal 1, then we + -- can just return the left hand operand. Putting the optimization + -- here allows us to omit the check at the call site. + + if Nkind (R) = N_Integer_Literal and then Intval (R) = 1 then + return L; + end if; + + -- If left and right types are the same, no conversion needed + + if Left_Type = Right_Type then + Result_Type := Left_Type; + Rnode := + Make_Op_Divide (Loc, + Left_Opnd => L, + Right_Opnd => R); + + -- Use left type if it is the larger of the two + + elsif Esize (Left_Type) >= Esize (Right_Type) then + Result_Type := Left_Type; + Rnode := + Make_Op_Divide (Loc, + Left_Opnd => L, + Right_Opnd => Build_Conversion (N, Left_Type, R)); + + -- Otherwise right type is larger of the two, us it + + else + Result_Type := Right_Type; + Rnode := + Make_Op_Divide (Loc, + Left_Opnd => Build_Conversion (N, Right_Type, L), + Right_Opnd => R); + end if; + end if; + + -- We now have a divide node built with Result_Type set. First + -- set Etype of result, as required for all Build_xxx routines + + Set_Etype (Rnode, Base_Type (Result_Type)); + + -- Set Treat_Fixed_As_Integer if operation on fixed-point type + -- since this is a literal arithmetic operation, to be performed + -- by Gigi without any consideration of small values. + + if Is_Fixed_Point_Type (Result_Type) then + Set_Treat_Fixed_As_Integer (Rnode); + end if; + + -- The result is rounded if the target of the operation is decimal + -- and Rounded_Result is set, or if the target of the operation + -- is an integer type. + + if Is_Integer_Type (Etype (N)) + or else Rounded_Result_Set (N) + then + Set_Rounded_Result (Rnode); + end if; + + return Rnode; + end Build_Divide; + + ------------------------- + -- Build_Double_Divide -- + ------------------------- + + function Build_Double_Divide + (N : Node_Id; + X, Y, Z : Node_Id) return Node_Id + is + Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y))); + Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z))); + Expr : Node_Id; + + begin + -- If denominator fits in 64 bits, we can build the operations directly + -- without causing any intermediate overflow, so that's what we do. + + if Nat'Max (Y_Size, Z_Size) <= 32 then + return + Build_Divide (N, X, Build_Multiply (N, Y, Z)); + + -- Otherwise we use the runtime routine + + -- [Qnn : Interfaces.Integer_64, + -- Rnn : Interfaces.Integer_64; + -- Double_Divide (X, Y, Z, Qnn, Rnn, Round); + -- Qnn] + + else + declare + Loc : constant Source_Ptr := Sloc (N); + Qnn : Entity_Id; + Rnn : Entity_Id; + Code : List_Id; + + pragma Warnings (Off, Rnn); + + begin + Build_Double_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code); + Insert_Actions (N, Code); + Expr := New_Occurrence_Of (Qnn, Loc); + + -- Set type of result in case used elsewhere (see note at start) + + Set_Etype (Expr, Etype (Qnn)); + + -- Set result as analyzed (see note at start on build routines) + + return Expr; + end; + end if; + end Build_Double_Divide; + + ------------------------------ + -- Build_Double_Divide_Code -- + ------------------------------ + + -- If the denominator can be computed in 64-bits, we build + + -- [Nnn : constant typ := typ (X); + -- Dnn : constant typ := typ (Y) * typ (Z) + -- Qnn : constant typ := Nnn / Dnn; + -- Rnn : constant typ := Nnn / Dnn; + + -- If the numerator cannot be computed in 64 bits, we build + + -- [Qnn : typ; + -- Rnn : typ; + -- Double_Divide (X, Y, Z, Qnn, Rnn, Round);] + + procedure Build_Double_Divide_Code + (N : Node_Id; + X, Y, Z : Node_Id; + Qnn, Rnn : out Entity_Id; + Code : out List_Id) + is + Loc : constant Source_Ptr := Sloc (N); + + X_Size : constant Nat := UI_To_Int (Esize (Etype (X))); + Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y))); + Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z))); + + QR_Siz : Nat; + QR_Typ : Entity_Id; + + Nnn : Entity_Id; + Dnn : Entity_Id; + + Quo : Node_Id; + Rnd : Entity_Id; + + begin + -- Find type that will allow computation of numerator + + QR_Siz := Nat'Max (X_Size, 2 * Nat'Max (Y_Size, Z_Size)); + + if QR_Siz <= 16 then + QR_Typ := Standard_Integer_16; + elsif QR_Siz <= 32 then + QR_Typ := Standard_Integer_32; + elsif QR_Siz <= 64 then + QR_Typ := Standard_Integer_64; + + -- For more than 64, bits, we use the 64-bit integer defined in + -- Interfaces, so that it can be handled by the runtime routine. + + else + QR_Typ := RTE (RE_Integer_64); + end if; + + -- Define quotient and remainder, and set their Etypes, so + -- that they can be picked up by Build_xxx routines. + + Qnn := Make_Temporary (Loc, 'S'); + Rnn := Make_Temporary (Loc, 'R'); + + Set_Etype (Qnn, QR_Typ); + Set_Etype (Rnn, QR_Typ); + + -- Case that we can compute the denominator in 64 bits + + if QR_Siz <= 64 then + + -- Create temporaries for numerator and denominator and set Etypes, + -- so that New_Occurrence_Of picks them up for Build_xxx calls. + + Nnn := Make_Temporary (Loc, 'N'); + Dnn := Make_Temporary (Loc, 'D'); + + Set_Etype (Nnn, QR_Typ); + Set_Etype (Dnn, QR_Typ); + + Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Nnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => Build_Conversion (N, QR_Typ, X)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Dnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => + Build_Multiply (N, + Build_Conversion (N, QR_Typ, Y), + Build_Conversion (N, QR_Typ, Z)))); + + Quo := + Build_Divide (N, + New_Occurrence_Of (Nnn, Loc), + New_Occurrence_Of (Dnn, Loc)); + + Set_Rounded_Result (Quo, Rounded_Result_Set (N)); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Qnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => Quo)); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => + Build_Rem (N, + New_Occurrence_Of (Nnn, Loc), + New_Occurrence_Of (Dnn, Loc)))); + + -- Case where denominator does not fit in 64 bits, so we have to + -- call the runtime routine to compute the quotient and remainder + + else + Rnd := Boolean_Literals (Rounded_Result_Set (N)); + + Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Qnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Double_Divide), Loc), + Parameter_Associations => New_List ( + Build_Conversion (N, QR_Typ, X), + Build_Conversion (N, QR_Typ, Y), + Build_Conversion (N, QR_Typ, Z), + New_Occurrence_Of (Qnn, Loc), + New_Occurrence_Of (Rnn, Loc), + New_Occurrence_Of (Rnd, Loc)))); + end if; + end Build_Double_Divide_Code; + + -------------------- + -- Build_Multiply -- + -------------------- + + function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Left_Type : constant Entity_Id := Etype (L); + Right_Type : constant Entity_Id := Etype (R); + Left_Size : Int; + Right_Size : Int; + Rsize : Int; + Result_Type : Entity_Id; + Rnode : Node_Id; + + begin + -- Deal with floating-point case first + + if Is_Floating_Point_Type (Left_Type) then + pragma Assert (Left_Type = Universal_Real); + pragma Assert (Right_Type = Universal_Real); + + Result_Type := Universal_Real; + Rnode := Make_Op_Multiply (Loc, L, R); + + -- Integer and fixed-point cases + + else + -- An optimization. If the right operand is the literal 1, then we + -- can just return the left hand operand. Putting the optimization + -- here allows us to omit the check at the call site. Similarly, if + -- the left operand is the integer 1 we can return the right operand. + + if Nkind (R) = N_Integer_Literal and then Intval (R) = 1 then + return L; + elsif Nkind (L) = N_Integer_Literal and then Intval (L) = 1 then + return R; + end if; + + -- Otherwise we need to figure out the correct result type size + -- First figure out the effective sizes of the operands. Normally + -- the effective size of an operand is the RM_Size of the operand. + -- But a special case arises with operands whose size is known at + -- compile time. In this case, we can use the actual value of the + -- operand to get its size if it would fit signed in 8 or 16 bits. + + Left_Size := UI_To_Int (RM_Size (Left_Type)); + + if Compile_Time_Known_Value (L) then + declare + Val : constant Uint := Expr_Value (L); + begin + if Val < Int'(2 ** 7) then + Left_Size := 8; + elsif Val < Int'(2 ** 15) then + Left_Size := 16; + end if; + end; + end if; + + Right_Size := UI_To_Int (RM_Size (Right_Type)); + + if Compile_Time_Known_Value (R) then + declare + Val : constant Uint := Expr_Value (R); + begin + if Val <= Int'(2 ** 7) then + Right_Size := 8; + elsif Val <= Int'(2 ** 15) then + Right_Size := 16; + end if; + end; + end if; + + -- Now the result size must be at least twice the longer of + -- the two sizes, to accommodate all possible results. + + Rsize := 2 * Int'Max (Left_Size, Right_Size); + + if Rsize <= 8 then + Result_Type := Standard_Integer_8; + + elsif Rsize <= 16 then + Result_Type := Standard_Integer_16; + + elsif Rsize <= 32 then + Result_Type := Standard_Integer_32; + + else + Result_Type := Standard_Integer_64; + end if; + + Rnode := + Make_Op_Multiply (Loc, + Left_Opnd => Build_Conversion (N, Result_Type, L), + Right_Opnd => Build_Conversion (N, Result_Type, R)); + end if; + + -- We now have a multiply node built with Result_Type set. First + -- set Etype of result, as required for all Build_xxx routines + + Set_Etype (Rnode, Base_Type (Result_Type)); + + -- Set Treat_Fixed_As_Integer if operation on fixed-point type + -- since this is a literal arithmetic operation, to be performed + -- by Gigi without any consideration of small values. + + if Is_Fixed_Point_Type (Result_Type) then + Set_Treat_Fixed_As_Integer (Rnode); + end if; + + return Rnode; + end Build_Multiply; + + --------------- + -- Build_Rem -- + --------------- + + function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Left_Type : constant Entity_Id := Etype (L); + Right_Type : constant Entity_Id := Etype (R); + Result_Type : Entity_Id; + Rnode : Node_Id; + + begin + if Left_Type = Right_Type then + Result_Type := Left_Type; + Rnode := + Make_Op_Rem (Loc, + Left_Opnd => L, + Right_Opnd => R); + + -- If left size is larger, we do the remainder operation using the + -- size of the left type (i.e. the larger of the two integer types). + + elsif Esize (Left_Type) >= Esize (Right_Type) then + Result_Type := Left_Type; + Rnode := + Make_Op_Rem (Loc, + Left_Opnd => L, + Right_Opnd => Build_Conversion (N, Left_Type, R)); + + -- Similarly, if the right size is larger, we do the remainder + -- operation using the right type. + + else + Result_Type := Right_Type; + Rnode := + Make_Op_Rem (Loc, + Left_Opnd => Build_Conversion (N, Right_Type, L), + Right_Opnd => R); + end if; + + -- We now have an N_Op_Rem node built with Result_Type set. First + -- set Etype of result, as required for all Build_xxx routines + + Set_Etype (Rnode, Base_Type (Result_Type)); + + -- Set Treat_Fixed_As_Integer if operation on fixed-point type + -- since this is a literal arithmetic operation, to be performed + -- by Gigi without any consideration of small values. + + if Is_Fixed_Point_Type (Result_Type) then + Set_Treat_Fixed_As_Integer (Rnode); + end if; + + -- One more check. We did the rem operation using the larger of the + -- two types, which is reasonable. However, in the case where the + -- two types have unequal sizes, it is impossible for the result of + -- a remainder operation to be larger than the smaller of the two + -- types, so we can put a conversion round the result to keep the + -- evolving operation size as small as possible. + + if Esize (Left_Type) >= Esize (Right_Type) then + Rnode := Build_Conversion (N, Right_Type, Rnode); + elsif Esize (Right_Type) >= Esize (Left_Type) then + Rnode := Build_Conversion (N, Left_Type, Rnode); + end if; + + return Rnode; + end Build_Rem; + + ------------------------- + -- Build_Scaled_Divide -- + ------------------------- + + function Build_Scaled_Divide + (N : Node_Id; + X, Y, Z : Node_Id) return Node_Id + is + X_Size : constant Nat := UI_To_Int (Esize (Etype (X))); + Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y))); + Expr : Node_Id; + + begin + -- If numerator fits in 64 bits, we can build the operations directly + -- without causing any intermediate overflow, so that's what we do. + + if Nat'Max (X_Size, Y_Size) <= 32 then + return + Build_Divide (N, Build_Multiply (N, X, Y), Z); + + -- Otherwise we use the runtime routine + + -- [Qnn : Integer_64, + -- Rnn : Integer_64; + -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round); + -- Qnn] + + else + declare + Loc : constant Source_Ptr := Sloc (N); + Qnn : Entity_Id; + Rnn : Entity_Id; + Code : List_Id; + + pragma Warnings (Off, Rnn); + + begin + Build_Scaled_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code); + Insert_Actions (N, Code); + Expr := New_Occurrence_Of (Qnn, Loc); + + -- Set type of result in case used elsewhere (see note at start) + + Set_Etype (Expr, Etype (Qnn)); + return Expr; + end; + end if; + end Build_Scaled_Divide; + + ------------------------------ + -- Build_Scaled_Divide_Code -- + ------------------------------ + + -- If the numerator can be computed in 64-bits, we build + + -- [Nnn : constant typ := typ (X) * typ (Y); + -- Dnn : constant typ := typ (Z) + -- Qnn : constant typ := Nnn / Dnn; + -- Rnn : constant typ := Nnn / Dnn; + + -- If the numerator cannot be computed in 64 bits, we build + + -- [Qnn : Interfaces.Integer_64; + -- Rnn : Interfaces.Integer_64; + -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round);] + + procedure Build_Scaled_Divide_Code + (N : Node_Id; + X, Y, Z : Node_Id; + Qnn, Rnn : out Entity_Id; + Code : out List_Id) + is + Loc : constant Source_Ptr := Sloc (N); + + X_Size : constant Nat := UI_To_Int (Esize (Etype (X))); + Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y))); + Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z))); + + QR_Siz : Nat; + QR_Typ : Entity_Id; + + Nnn : Entity_Id; + Dnn : Entity_Id; + + Quo : Node_Id; + Rnd : Entity_Id; + + begin + -- Find type that will allow computation of numerator + + QR_Siz := Nat'Max (X_Size, 2 * Nat'Max (Y_Size, Z_Size)); + + if QR_Siz <= 16 then + QR_Typ := Standard_Integer_16; + elsif QR_Siz <= 32 then + QR_Typ := Standard_Integer_32; + elsif QR_Siz <= 64 then + QR_Typ := Standard_Integer_64; + + -- For more than 64, bits, we use the 64-bit integer defined in + -- Interfaces, so that it can be handled by the runtime routine. + + else + QR_Typ := RTE (RE_Integer_64); + end if; + + -- Define quotient and remainder, and set their Etypes, so + -- that they can be picked up by Build_xxx routines. + + Qnn := Make_Temporary (Loc, 'S'); + Rnn := Make_Temporary (Loc, 'R'); + + Set_Etype (Qnn, QR_Typ); + Set_Etype (Rnn, QR_Typ); + + -- Case that we can compute the numerator in 64 bits + + if QR_Siz <= 64 then + Nnn := Make_Temporary (Loc, 'N'); + Dnn := Make_Temporary (Loc, 'D'); + + -- Set Etypes, so that they can be picked up by New_Occurrence_Of + + Set_Etype (Nnn, QR_Typ); + Set_Etype (Dnn, QR_Typ); + + Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Nnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => + Build_Multiply (N, + Build_Conversion (N, QR_Typ, X), + Build_Conversion (N, QR_Typ, Y))), + + Make_Object_Declaration (Loc, + Defining_Identifier => Dnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => Build_Conversion (N, QR_Typ, Z))); + + Quo := + Build_Divide (N, + New_Occurrence_Of (Nnn, Loc), + New_Occurrence_Of (Dnn, Loc)); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Qnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => Quo)); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => + Build_Rem (N, + New_Occurrence_Of (Nnn, Loc), + New_Occurrence_Of (Dnn, Loc)))); + + -- Case where numerator does not fit in 64 bits, so we have to + -- call the runtime routine to compute the quotient and remainder + + else + Rnd := Boolean_Literals (Rounded_Result_Set (N)); + + Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Qnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Scaled_Divide), Loc), + Parameter_Associations => New_List ( + Build_Conversion (N, QR_Typ, X), + Build_Conversion (N, QR_Typ, Y), + Build_Conversion (N, QR_Typ, Z), + New_Occurrence_Of (Qnn, Loc), + New_Occurrence_Of (Rnn, Loc), + New_Occurrence_Of (Rnd, Loc)))); + end if; + + -- Set type of result, for use in caller + + Set_Etype (Qnn, QR_Typ); + end Build_Scaled_Divide_Code; + + --------------------------- + -- Do_Divide_Fixed_Fixed -- + --------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = + -- (Left_Value * Left_Small) / (Right_Value * Right_Small) + + -- Result_Value = (Left_Value / Right_Value) * + -- (Left_Small / (Right_Small * Result_Small)); + + -- we can do the operation in integer arithmetic if this fraction is an + -- integer or the reciprocal of an integer, as detailed in (RM G.2.3(21)). + -- Otherwise the result is in the close result set and our approach is to + -- use floating-point to compute this close result. + + procedure Do_Divide_Fixed_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Left_Type : constant Entity_Id := Etype (Left); + Right_Type : constant Entity_Id := Etype (Right); + Result_Type : constant Entity_Id := Etype (N); + Right_Small : constant Ureal := Small_Value (Right_Type); + Left_Small : constant Ureal := Small_Value (Left_Type); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_Int : Node_Id; + + begin + -- Rounding is required if the result is integral + + if Is_Integer_Type (Result_Type) then + Set_Rounded_Result (N); + end if; + + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Get small ratio + + Frac := Left_Small / (Right_Small * Result_Small); + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- If the fraction is an integer, then we get the result by multiplying + -- the left operand by the integer, and then dividing by the right + -- operand (the order is important, if we did the divide first, we + -- would lose precision). + + if Frac_Den = 1 then + Lit_Int := Integer_Literal (N, Frac_Num); -- always positive + + if Present (Lit_Int) then + Set_Result (N, Build_Scaled_Divide (N, Left, Lit_Int, Right)); + return; + end if; + + -- If the fraction is the reciprocal of an integer, then we get the + -- result by first multiplying the divisor by the integer, and then + -- doing the division with the adjusted divisor. + + -- Note: this is much better than doing two divisions: multiplications + -- are much faster than divisions (and certainly faster than rounded + -- divisions), and we don't get inaccuracies from double rounding. + + elsif Frac_Num = 1 then + Lit_Int := Integer_Literal (N, Frac_Den); -- always positive + + if Present (Lit_Int) then + Set_Result (N, Build_Double_Divide (N, Left, Right, Lit_Int)); + return; + end if; + end if; + + -- If we fall through, we use floating-point to compute the result + + Set_Result (N, + Build_Multiply (N, + Build_Divide (N, Fpt_Value (Left), Fpt_Value (Right)), + Real_Literal (N, Frac))); + end Do_Divide_Fixed_Fixed; + + ------------------------------- + -- Do_Divide_Fixed_Universal -- + ------------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = (Left_Value * Left_Small) / Lit_Value; + -- Result_Value = Left_Value * Left_Small /(Lit_Value * Result_Small); + + -- The result is required to be in the perfect result set if the literal + -- can be factored so that the resulting small ratio is an integer or the + -- reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed + -- analysis of these RM requirements: + + -- We must factor the literal, finding an integer K: + + -- Lit_Value = K * Right_Small + -- Right_Small = Lit_Value / K + + -- such that the small ratio: + + -- Left_Small + -- ------------------------------ + -- (Lit_Value / K) * Result_Small + + -- Left_Small + -- = ------------------------ * K + -- Lit_Value * Result_Small + + -- is an integer or the reciprocal of an integer, and for + -- implementation efficiency we need the smallest such K. + + -- First we reduce the left fraction to lowest terms + + -- If numerator = 1, then for K = 1, the small ratio is the reciprocal + -- of an integer, and this is clearly the minimum K case, so set K = 1, + -- Right_Small = Lit_Value. + + -- If numerator > 1, then set K to the denominator of the fraction so + -- that the resulting small ratio is an integer (the numerator value). + + procedure Do_Divide_Fixed_Universal (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Left_Type : constant Entity_Id := Etype (Left); + Result_Type : constant Entity_Id := Etype (N); + Left_Small : constant Ureal := Small_Value (Left_Type); + Lit_Value : constant Ureal := Realval (Right); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_K : Node_Id; + Lit_Int : Node_Id; + + begin + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Determine if literal can be rewritten successfully + + Frac := Left_Small / (Lit_Value * Result_Small); + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- Case where fraction is the reciprocal of an integer (K = 1, integer + -- = denominator). If this integer is not too large, this is the case + -- where the result can be obtained by dividing by this integer value. + + if Frac_Num = 1 then + Lit_Int := Integer_Literal (N, Frac_Den, UR_Is_Negative (Frac)); + + if Present (Lit_Int) then + Set_Result (N, Build_Divide (N, Left, Lit_Int)); + return; + end if; + + -- Case where we choose K to make fraction an integer (K = denominator + -- of fraction, integer = numerator of fraction). If both K and the + -- numerator are small enough, this is the case where the result can + -- be obtained by first multiplying by the integer value and then + -- dividing by K (the order is important, if we divided first, we + -- would lose precision). + + else + Lit_Int := Integer_Literal (N, Frac_Num, UR_Is_Negative (Frac)); + Lit_K := Integer_Literal (N, Frac_Den, False); + + if Present (Lit_Int) and then Present (Lit_K) then + Set_Result (N, Build_Scaled_Divide (N, Left, Lit_Int, Lit_K)); + return; + end if; + end if; + + -- Fall through if the literal cannot be successfully rewritten, or if + -- the small ratio is out of range of integer arithmetic. In the former + -- case it is fine to use floating-point to get the close result set, + -- and in the latter case, it means that the result is zero or raises + -- constraint error, and we can do that accurately in floating-point. + + -- If we end up using floating-point, then we take the right integer + -- to be one, and its small to be the value of the original right real + -- literal. That way, we need only one floating-point multiplication. + + Set_Result (N, + Build_Multiply (N, Fpt_Value (Left), Real_Literal (N, Frac))); + end Do_Divide_Fixed_Universal; + + ------------------------------- + -- Do_Divide_Universal_Fixed -- + ------------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = + -- Lit_Value / (Right_Value * Right_Small) + -- Result_Value = + -- (Lit_Value / (Right_Small * Result_Small)) / Right_Value + + -- The result is required to be in the perfect result set if the literal + -- can be factored so that the resulting small ratio is an integer or the + -- reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed + -- analysis of these RM requirements: + + -- We must factor the literal, finding an integer K: + + -- Lit_Value = K * Left_Small + -- Left_Small = Lit_Value / K + + -- such that the small ratio: + + -- (Lit_Value / K) + -- -------------------------- + -- Right_Small * Result_Small + + -- Lit_Value 1 + -- = -------------------------- * - + -- Right_Small * Result_Small K + + -- is an integer or the reciprocal of an integer, and for + -- implementation efficiency we need the smallest such K. + + -- First we reduce the left fraction to lowest terms + + -- If denominator = 1, then for K = 1, the small ratio is an integer + -- (the numerator) and this is clearly the minimum K case, so set K = 1, + -- and Left_Small = Lit_Value. + + -- If denominator > 1, then set K to the numerator of the fraction so + -- that the resulting small ratio is the reciprocal of an integer (the + -- numerator value). + + procedure Do_Divide_Universal_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Right_Type : constant Entity_Id := Etype (Right); + Result_Type : constant Entity_Id := Etype (N); + Right_Small : constant Ureal := Small_Value (Right_Type); + Lit_Value : constant Ureal := Realval (Left); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_K : Node_Id; + Lit_Int : Node_Id; + + begin + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Determine if literal can be rewritten successfully + + Frac := Lit_Value / (Right_Small * Result_Small); + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- Case where fraction is an integer (K = 1, integer = numerator). If + -- this integer is not too large, this is the case where the result + -- can be obtained by dividing this integer by the right operand. + + if Frac_Den = 1 then + Lit_Int := Integer_Literal (N, Frac_Num, UR_Is_Negative (Frac)); + + if Present (Lit_Int) then + Set_Result (N, Build_Divide (N, Lit_Int, Right)); + return; + end if; + + -- Case where we choose K to make the fraction the reciprocal of an + -- integer (K = numerator of fraction, integer = numerator of fraction). + -- If both K and the integer are small enough, this is the case where + -- the result can be obtained by multiplying the right operand by K + -- and then dividing by the integer value. The order of the operations + -- is important (if we divided first, we would lose precision). + + else + Lit_Int := Integer_Literal (N, Frac_Den, UR_Is_Negative (Frac)); + Lit_K := Integer_Literal (N, Frac_Num, False); + + if Present (Lit_Int) and then Present (Lit_K) then + Set_Result (N, Build_Double_Divide (N, Lit_K, Right, Lit_Int)); + return; + end if; + end if; + + -- Fall through if the literal cannot be successfully rewritten, or if + -- the small ratio is out of range of integer arithmetic. In the former + -- case it is fine to use floating-point to get the close result set, + -- and in the latter case, it means that the result is zero or raises + -- constraint error, and we can do that accurately in floating-point. + + -- If we end up using floating-point, then we take the right integer + -- to be one, and its small to be the value of the original right real + -- literal. That way, we need only one floating-point division. + + Set_Result (N, + Build_Divide (N, Real_Literal (N, Frac), Fpt_Value (Right))); + end Do_Divide_Universal_Fixed; + + ----------------------------- + -- Do_Multiply_Fixed_Fixed -- + ----------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = + -- (Left_Value * Left_Small) * (Right_Value * Right_Small) + + -- Result_Value = (Left_Value * Right_Value) * + -- (Left_Small * Right_Small) / Result_Small; + + -- we can do the operation in integer arithmetic if this fraction is an + -- integer or the reciprocal of an integer, as detailed in (RM G.2.3(21)). + -- Otherwise the result is in the close result set and our approach is to + -- use floating-point to compute this close result. + + procedure Do_Multiply_Fixed_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + Left_Type : constant Entity_Id := Etype (Left); + Right_Type : constant Entity_Id := Etype (Right); + Result_Type : constant Entity_Id := Etype (N); + Right_Small : constant Ureal := Small_Value (Right_Type); + Left_Small : constant Ureal := Small_Value (Left_Type); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_Int : Node_Id; + + begin + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Get small ratio + + Frac := (Left_Small * Right_Small) / Result_Small; + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- If the fraction is an integer, then we get the result by multiplying + -- the operands, and then multiplying the result by the integer value. + + if Frac_Den = 1 then + Lit_Int := Integer_Literal (N, Frac_Num); -- always positive + + if Present (Lit_Int) then + Set_Result (N, + Build_Multiply (N, Build_Multiply (N, Left, Right), + Lit_Int)); + return; + end if; + + -- If the fraction is the reciprocal of an integer, then we get the + -- result by multiplying the operands, and then dividing the result by + -- the integer value. The order of the operations is important, if we + -- divided first, we would lose precision. + + elsif Frac_Num = 1 then + Lit_Int := Integer_Literal (N, Frac_Den); -- always positive + + if Present (Lit_Int) then + Set_Result (N, Build_Scaled_Divide (N, Left, Right, Lit_Int)); + return; + end if; + end if; + + -- If we fall through, we use floating-point to compute the result + + Set_Result (N, + Build_Multiply (N, + Build_Multiply (N, Fpt_Value (Left), Fpt_Value (Right)), + Real_Literal (N, Frac))); + end Do_Multiply_Fixed_Fixed; + + --------------------------------- + -- Do_Multiply_Fixed_Universal -- + --------------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = (Left_Value * Left_Small) * Lit_Value; + -- Result_Value = Left_Value * (Left_Small * Lit_Value) / Result_Small; + + -- The result is required to be in the perfect result set if the literal + -- can be factored so that the resulting small ratio is an integer or the + -- reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed + -- analysis of these RM requirements: + + -- We must factor the literal, finding an integer K: + + -- Lit_Value = K * Right_Small + -- Right_Small = Lit_Value / K + + -- such that the small ratio: + + -- Left_Small * (Lit_Value / K) + -- ---------------------------- + -- Result_Small + + -- Left_Small * Lit_Value 1 + -- = ---------------------- * - + -- Result_Small K + + -- is an integer or the reciprocal of an integer, and for + -- implementation efficiency we need the smallest such K. + + -- First we reduce the left fraction to lowest terms + + -- If denominator = 1, then for K = 1, the small ratio is an integer, and + -- this is clearly the minimum K case, so set + + -- K = 1, Right_Small = Lit_Value + + -- If denominator > 1, then set K to the numerator of the fraction, so + -- that the resulting small ratio is the reciprocal of the integer (the + -- denominator value). + + procedure Do_Multiply_Fixed_Universal + (N : Node_Id; + Left, Right : Node_Id) + is + Left_Type : constant Entity_Id := Etype (Left); + Result_Type : constant Entity_Id := Etype (N); + Left_Small : constant Ureal := Small_Value (Left_Type); + Lit_Value : constant Ureal := Realval (Right); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_K : Node_Id; + Lit_Int : Node_Id; + + begin + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Determine if literal can be rewritten successfully + + Frac := (Left_Small * Lit_Value) / Result_Small; + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- Case where fraction is an integer (K = 1, integer = numerator). If + -- this integer is not too large, this is the case where the result can + -- be obtained by multiplying by this integer value. + + if Frac_Den = 1 then + Lit_Int := Integer_Literal (N, Frac_Num, UR_Is_Negative (Frac)); + + if Present (Lit_Int) then + Set_Result (N, Build_Multiply (N, Left, Lit_Int)); + return; + end if; + + -- Case where we choose K to make fraction the reciprocal of an integer + -- (K = numerator of fraction, integer = denominator of fraction). If + -- both K and the denominator are small enough, this is the case where + -- the result can be obtained by first multiplying by K, and then + -- dividing by the integer value. + + else + Lit_Int := Integer_Literal (N, Frac_Den, UR_Is_Negative (Frac)); + Lit_K := Integer_Literal (N, Frac_Num); + + if Present (Lit_Int) and then Present (Lit_K) then + Set_Result (N, Build_Scaled_Divide (N, Left, Lit_K, Lit_Int)); + return; + end if; + end if; + + -- Fall through if the literal cannot be successfully rewritten, or if + -- the small ratio is out of range of integer arithmetic. In the former + -- case it is fine to use floating-point to get the close result set, + -- and in the latter case, it means that the result is zero or raises + -- constraint error, and we can do that accurately in floating-point. + + -- If we end up using floating-point, then we take the right integer + -- to be one, and its small to be the value of the original right real + -- literal. That way, we need only one floating-point multiplication. + + Set_Result (N, + Build_Multiply (N, Fpt_Value (Left), Real_Literal (N, Frac))); + end Do_Multiply_Fixed_Universal; + + --------------------------------- + -- Expand_Convert_Fixed_Static -- + --------------------------------- + + procedure Expand_Convert_Fixed_Static (N : Node_Id) is + begin + Rewrite (N, + Convert_To (Etype (N), + Make_Real_Literal (Sloc (N), Expr_Value_R (Expression (N))))); + Analyze_And_Resolve (N); + end Expand_Convert_Fixed_Static; + + ----------------------------------- + -- Expand_Convert_Fixed_To_Fixed -- + ----------------------------------- + + -- We have: + + -- Result_Value * Result_Small = Source_Value * Source_Small + -- Result_Value = Source_Value * (Source_Small / Result_Small) + + -- If the small ratio (Source_Small / Result_Small) is a sufficiently small + -- integer, then the perfect result set is obtained by a single integer + -- multiplication. + + -- If the small ratio is the reciprocal of a sufficiently small integer, + -- then the perfect result set is obtained by a single integer division. + + -- In other cases, we obtain the close result set by calculating the + -- result in floating-point. + + procedure Expand_Convert_Fixed_To_Fixed (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Result_Type : constant Entity_Id := Etype (N); + Source_Type : constant Entity_Id := Etype (Expr); + Small_Ratio : Ureal; + Ratio_Num : Uint; + Ratio_Den : Uint; + Lit : Node_Id; + + begin + if Is_OK_Static_Expression (Expr) then + Expand_Convert_Fixed_Static (N); + return; + end if; + + Small_Ratio := Small_Value (Source_Type) / Small_Value (Result_Type); + Ratio_Num := Norm_Num (Small_Ratio); + Ratio_Den := Norm_Den (Small_Ratio); + + if Ratio_Den = 1 then + if Ratio_Num = 1 then + Set_Result (N, Expr); + return; + + else + Lit := Integer_Literal (N, Ratio_Num); + + if Present (Lit) then + Set_Result (N, Build_Multiply (N, Expr, Lit)); + return; + end if; + end if; + + elsif Ratio_Num = 1 then + Lit := Integer_Literal (N, Ratio_Den); + + if Present (Lit) then + Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check); + return; + end if; + end if; + + -- Fall through to use floating-point for the close result set case + -- either as a result of the small ratio not being an integer or the + -- reciprocal of an integer, or if the integer is out of range. + + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Small_Ratio)), + Rng_Check); + end Expand_Convert_Fixed_To_Fixed; + + ----------------------------------- + -- Expand_Convert_Fixed_To_Float -- + ----------------------------------- + + -- If the small of the fixed type is 1.0, then we simply convert the + -- integer value directly to the target floating-point type, otherwise + -- we first have to multiply by the small, in Universal_Real, and then + -- convert the result to the target floating-point type. + + procedure Expand_Convert_Fixed_To_Float (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Source_Type : constant Entity_Id := Etype (Expr); + Small : constant Ureal := Small_Value (Source_Type); + + begin + if Is_OK_Static_Expression (Expr) then + Expand_Convert_Fixed_Static (N); + return; + end if; + + if Small = Ureal_1 then + Set_Result (N, Expr); + + else + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Small)), + Rng_Check); + end if; + end Expand_Convert_Fixed_To_Float; + + ------------------------------------- + -- Expand_Convert_Fixed_To_Integer -- + ------------------------------------- + + -- We have: + + -- Result_Value = Source_Value * Source_Small + + -- If the small value is a sufficiently small integer, then the perfect + -- result set is obtained by a single integer multiplication. + + -- If the small value is the reciprocal of a sufficiently small integer, + -- then the perfect result set is obtained by a single integer division. + + -- In other cases, we obtain the close result set by calculating the + -- result in floating-point. + + procedure Expand_Convert_Fixed_To_Integer (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Source_Type : constant Entity_Id := Etype (Expr); + Small : constant Ureal := Small_Value (Source_Type); + Small_Num : constant Uint := Norm_Num (Small); + Small_Den : constant Uint := Norm_Den (Small); + Lit : Node_Id; + + begin + if Is_OK_Static_Expression (Expr) then + Expand_Convert_Fixed_Static (N); + return; + end if; + + if Small_Den = 1 then + Lit := Integer_Literal (N, Small_Num); + + if Present (Lit) then + Set_Result (N, Build_Multiply (N, Expr, Lit), Rng_Check); + return; + end if; + + elsif Small_Num = 1 then + Lit := Integer_Literal (N, Small_Den); + + if Present (Lit) then + Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check); + return; + end if; + end if; + + -- Fall through to use floating-point for the close result set case + -- either as a result of the small value not being an integer or the + -- reciprocal of an integer, or if the integer is out of range. + + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Small)), + Rng_Check); + end Expand_Convert_Fixed_To_Integer; + + ----------------------------------- + -- Expand_Convert_Float_To_Fixed -- + ----------------------------------- + + -- We have + + -- Result_Value * Result_Small = Operand_Value + + -- so compute: + + -- Result_Value = Operand_Value * (1.0 / Result_Small) + + -- We do the small scaling in floating-point, and we do a multiplication + -- rather than a division, since it is accurate enough for the perfect + -- result cases, and faster. + + procedure Expand_Convert_Float_To_Fixed (N : Node_Id) is + Expr : constant Node_Id := Expression (N); + Orig_N : constant Node_Id := Original_Node (N); + Result_Type : constant Entity_Id := Etype (N); + Rng_Check : constant Boolean := Do_Range_Check (N); + Small : constant Ureal := Small_Value (Result_Type); + Truncate : Boolean; + + begin + -- Optimize small = 1, where we can avoid the multiply completely + + if Small = Ureal_1 then + Set_Result (N, Expr, Rng_Check, Trunc => True); + + -- Normal case where multiply is required. Rounding is truncating + -- for decimal fixed point types only, see RM 4.6(29), except if the + -- conversion comes from an attribute reference 'Round (RM 3.5.10 (14)): + -- The attribute is implemented by means of a conversion that must + -- round. + + else + if Is_Decimal_Fixed_Point_Type (Result_Type) then + Truncate := + Nkind (Orig_N) /= N_Attribute_Reference + or else Get_Attribute_Id + (Attribute_Name (Orig_N)) /= Attribute_Round; + else + Truncate := False; + end if; + + Set_Result + (N => N, + Expr => + Build_Multiply + (N => N, + L => Fpt_Value (Expr), + R => Real_Literal (N, Ureal_1 / Small)), + Rchk => Rng_Check, + Trunc => Truncate); + end if; + end Expand_Convert_Float_To_Fixed; + + ------------------------------------- + -- Expand_Convert_Integer_To_Fixed -- + ------------------------------------- + + -- We have + + -- Result_Value * Result_Small = Operand_Value + -- Result_Value = Operand_Value / Result_Small + + -- If the small value is a sufficiently small integer, then the perfect + -- result set is obtained by a single integer division. + + -- If the small value is the reciprocal of a sufficiently small integer, + -- the perfect result set is obtained by a single integer multiplication. + + -- In other cases, we obtain the close result set by calculating the + -- result in floating-point using a multiplication by the reciprocal + -- of the Result_Small. + + procedure Expand_Convert_Integer_To_Fixed (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Result_Type : constant Entity_Id := Etype (N); + Small : constant Ureal := Small_Value (Result_Type); + Small_Num : constant Uint := Norm_Num (Small); + Small_Den : constant Uint := Norm_Den (Small); + Lit : Node_Id; + + begin + if Small_Den = 1 then + Lit := Integer_Literal (N, Small_Num); + + if Present (Lit) then + Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check); + return; + end if; + + elsif Small_Num = 1 then + Lit := Integer_Literal (N, Small_Den); + + if Present (Lit) then + Set_Result (N, Build_Multiply (N, Expr, Lit), Rng_Check); + return; + end if; + end if; + + -- Fall through to use floating-point for the close result set case + -- either as a result of the small value not being an integer or the + -- reciprocal of an integer, or if the integer is out of range. + + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Ureal_1 / Small)), + Rng_Check); + end Expand_Convert_Integer_To_Fixed; + + -------------------------------- + -- Expand_Decimal_Divide_Call -- + -------------------------------- + + -- We have four operands + + -- Dividend + -- Divisor + -- Quotient + -- Remainder + + -- All of which are decimal types, and which thus have associated + -- decimal scales. + + -- Computing the quotient is a similar problem to that faced by the + -- normal fixed-point division, except that it is simpler, because + -- we always have compatible smalls. + + -- Quotient = (Dividend / Divisor) * 10**q + + -- where 10 ** q = Dividend'Small / (Divisor'Small * Quotient'Small) + -- so q = Divisor'Scale + Quotient'Scale - Dividend'Scale + + -- For q >= 0, we compute + + -- Numerator := Dividend * 10 ** q + -- Denominator := Divisor + -- Quotient := Numerator / Denominator + + -- For q < 0, we compute + + -- Numerator := Dividend + -- Denominator := Divisor * 10 ** q + -- Quotient := Numerator / Denominator + + -- Both these divisions are done in truncated mode, and the remainder + -- from these divisions is used to compute the result Remainder. This + -- remainder has the effective scale of the numerator of the division, + + -- For q >= 0, the remainder scale is Dividend'Scale + q + -- For q < 0, the remainder scale is Dividend'Scale + + -- The result Remainder is then computed by a normal truncating decimal + -- conversion from this scale to the scale of the remainder, i.e. by a + -- division or multiplication by the appropriate power of 10. + + procedure Expand_Decimal_Divide_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Dividend : Node_Id := First_Actual (N); + Divisor : Node_Id := Next_Actual (Dividend); + Quotient : Node_Id := Next_Actual (Divisor); + Remainder : Node_Id := Next_Actual (Quotient); + + Dividend_Type : constant Entity_Id := Etype (Dividend); + Divisor_Type : constant Entity_Id := Etype (Divisor); + Quotient_Type : constant Entity_Id := Etype (Quotient); + Remainder_Type : constant Entity_Id := Etype (Remainder); + + Dividend_Scale : constant Uint := Scale_Value (Dividend_Type); + Divisor_Scale : constant Uint := Scale_Value (Divisor_Type); + Quotient_Scale : constant Uint := Scale_Value (Quotient_Type); + Remainder_Scale : constant Uint := Scale_Value (Remainder_Type); + + Q : Uint; + Numerator_Scale : Uint; + Stmts : List_Id; + Qnn : Entity_Id; + Rnn : Entity_Id; + Computed_Remainder : Node_Id; + Adjusted_Remainder : Node_Id; + Scale_Adjust : Uint; + + begin + -- Relocate the operands, since they are now list elements, and we + -- need to reference them separately as operands in the expanded code. + + Dividend := Relocate_Node (Dividend); + Divisor := Relocate_Node (Divisor); + Quotient := Relocate_Node (Quotient); + Remainder := Relocate_Node (Remainder); + + -- Now compute Q, the adjustment scale + + Q := Divisor_Scale + Quotient_Scale - Dividend_Scale; + + -- If Q is non-negative then we need a scaled divide + + if Q >= 0 then + Build_Scaled_Divide_Code + (N, + Dividend, + Integer_Literal (N, Uint_10 ** Q), + Divisor, + Qnn, Rnn, Stmts); + + Numerator_Scale := Dividend_Scale + Q; + + -- If Q is negative, then we need a double divide + + else + Build_Double_Divide_Code + (N, + Dividend, + Divisor, + Integer_Literal (N, Uint_10 ** (-Q)), + Qnn, Rnn, Stmts); + + Numerator_Scale := Dividend_Scale; + end if; + + -- Add statement to set quotient value + + -- Quotient := quotient-type!(Qnn); + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Quotient, + Expression => + Unchecked_Convert_To (Quotient_Type, + Build_Conversion (N, Quotient_Type, + New_Occurrence_Of (Qnn, Loc))))); + + -- Now we need to deal with computing and setting the remainder. The + -- scale of the remainder is in Numerator_Scale, and the desired + -- scale is the scale of the given Remainder argument. There are + -- three cases: + + -- Numerator_Scale > Remainder_Scale + + -- in this case, there are extra digits in the computed remainder + -- which must be eliminated by an extra division: + + -- computed-remainder := Numerator rem Denominator + -- scale_adjust = Numerator_Scale - Remainder_Scale + -- adjusted-remainder := computed-remainder / 10 ** scale_adjust + + -- Numerator_Scale = Remainder_Scale + + -- in this case, the we have the remainder we need + + -- computed-remainder := Numerator rem Denominator + -- adjusted-remainder := computed-remainder + + -- Numerator_Scale < Remainder_Scale + + -- in this case, we have insufficient digits in the computed + -- remainder, which must be eliminated by an extra multiply + + -- computed-remainder := Numerator rem Denominator + -- scale_adjust = Remainder_Scale - Numerator_Scale + -- adjusted-remainder := computed-remainder * 10 ** scale_adjust + + -- Finally we assign the adjusted-remainder to the result Remainder + -- with conversions to get the proper fixed-point type representation. + + Computed_Remainder := New_Occurrence_Of (Rnn, Loc); + + if Numerator_Scale > Remainder_Scale then + Scale_Adjust := Numerator_Scale - Remainder_Scale; + Adjusted_Remainder := + Build_Divide + (N, Computed_Remainder, Integer_Literal (N, 10 ** Scale_Adjust)); + + elsif Numerator_Scale = Remainder_Scale then + Adjusted_Remainder := Computed_Remainder; + + else -- Numerator_Scale < Remainder_Scale + Scale_Adjust := Remainder_Scale - Numerator_Scale; + Adjusted_Remainder := + Build_Multiply + (N, Computed_Remainder, Integer_Literal (N, 10 ** Scale_Adjust)); + end if; + + -- Assignment of remainder result + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Remainder, + Expression => + Unchecked_Convert_To (Remainder_Type, Adjusted_Remainder))); + + -- Final step is to rewrite the call with a block containing the + -- above sequence of constructed statements for the divide operation. + + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts))); + + Analyze (N); + end Expand_Decimal_Divide_Call; + + ----------------------------------------------- + -- Expand_Divide_Fixed_By_Fixed_Giving_Fixed -- + ----------------------------------------------- + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + begin + -- Suppress expansion of a fixed-by-fixed division if the + -- operation is supported directly by the target. + + if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then + return; + end if; + + if Etype (Left) = Universal_Real then + Do_Divide_Universal_Fixed (N); + + elsif Etype (Right) = Universal_Real then + Do_Divide_Fixed_Universal (N); + + else + Do_Divide_Fixed_Fixed (N); + + -- A focused optimization: if after constant folding the + -- expression is of the form: T ((Exp * D) / D), where D is + -- a static constant, return T (Exp). This form will show up + -- when D is the denominator of the static expression for the + -- 'small of fixed-point types involved. This transformation + -- removes a division that may be expensive on some targets. + + if Nkind (N) = N_Type_Conversion + and then Nkind (Expression (N)) = N_Op_Divide + then + declare + Num : constant Node_Id := Left_Opnd (Expression (N)); + Den : constant Node_Id := Right_Opnd (Expression (N)); + + begin + if Nkind (Den) = N_Integer_Literal + and then Nkind (Num) = N_Op_Multiply + and then Nkind (Right_Opnd (Num)) = N_Integer_Literal + and then Intval (Den) = Intval (Right_Opnd (Num)) + then + Rewrite (Expression (N), Left_Opnd (Num)); + end if; + end; + end if; + end if; + end Expand_Divide_Fixed_By_Fixed_Giving_Fixed; + + ----------------------------------------------- + -- Expand_Divide_Fixed_By_Fixed_Giving_Float -- + ----------------------------------------------- + + -- The division is done in Universal_Real, and the result is multiplied + -- by the small ratio, which is Small (Right) / Small (Left). Special + -- treatment is required for universal operands, which represent their + -- own value and do not require conversion. + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Float (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + Left_Type : constant Entity_Id := Etype (Left); + Right_Type : constant Entity_Id := Etype (Right); + + begin + -- Case of left operand is universal real, the result we want is: + + -- Left_Value / (Right_Value * Right_Small) + + -- so we compute this as: + + -- (Left_Value / Right_Small) / Right_Value + + if Left_Type = Universal_Real then + Set_Result (N, + Build_Divide (N, + Real_Literal (N, Realval (Left) / Small_Value (Right_Type)), + Fpt_Value (Right))); + + -- Case of right operand is universal real, the result we want is + + -- (Left_Value * Left_Small) / Right_Value + + -- so we compute this as: + + -- Left_Value * (Left_Small / Right_Value) + + -- Note we invert to a multiplication since usually floating-point + -- multiplication is much faster than floating-point division. + + elsif Right_Type = Universal_Real then + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Left), + Real_Literal (N, Small_Value (Left_Type) / Realval (Right)))); + + -- Both operands are fixed, so the value we want is + + -- (Left_Value * Left_Small) / (Right_Value * Right_Small) + + -- which we compute as: + + -- (Left_Value / Right_Value) * (Left_Small / Right_Small) + + else + Set_Result (N, + Build_Multiply (N, + Build_Divide (N, Fpt_Value (Left), Fpt_Value (Right)), + Real_Literal (N, + Small_Value (Left_Type) / Small_Value (Right_Type)))); + end if; + end Expand_Divide_Fixed_By_Fixed_Giving_Float; + + ------------------------------------------------- + -- Expand_Divide_Fixed_By_Fixed_Giving_Integer -- + ------------------------------------------------- + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Integer (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + begin + if Etype (Left) = Universal_Real then + Do_Divide_Universal_Fixed (N); + elsif Etype (Right) = Universal_Real then + Do_Divide_Fixed_Universal (N); + else + Do_Divide_Fixed_Fixed (N); + end if; + end Expand_Divide_Fixed_By_Fixed_Giving_Integer; + + ------------------------------------------------- + -- Expand_Divide_Fixed_By_Integer_Giving_Fixed -- + ------------------------------------------------- + + -- Since the operand and result fixed-point type is the same, this is + -- a straight divide by the right operand, the small can be ignored. + + procedure Expand_Divide_Fixed_By_Integer_Giving_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + begin + Set_Result (N, Build_Divide (N, Left, Right)); + end Expand_Divide_Fixed_By_Integer_Giving_Fixed; + + ------------------------------------------------- + -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed -- + ------------------------------------------------- + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + procedure Rewrite_Non_Static_Universal (Opnd : Node_Id); + -- The operand may be a non-static universal value, such an + -- exponentiation with a non-static exponent. In that case, treat + -- as a fixed * fixed multiplication, and convert the argument to + -- the target fixed type. + + ---------------------------------- + -- Rewrite_Non_Static_Universal -- + ---------------------------------- + + procedure Rewrite_Non_Static_Universal (Opnd : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + begin + Rewrite (Opnd, + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Etype (N), Loc), + Expression => Expression (Opnd))); + Analyze_And_Resolve (Opnd, Etype (N)); + end Rewrite_Non_Static_Universal; + + -- Start of processing for Expand_Multiply_Fixed_By_Fixed_Giving_Fixed + + begin + -- Suppress expansion of a fixed-by-fixed multiplication if the + -- operation is supported directly by the target. + + if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then + return; + end if; + + if Etype (Left) = Universal_Real then + if Nkind (Left) = N_Real_Literal then + Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left); + + elsif Nkind (Left) = N_Type_Conversion then + Rewrite_Non_Static_Universal (Left); + Do_Multiply_Fixed_Fixed (N); + end if; + + elsif Etype (Right) = Universal_Real then + if Nkind (Right) = N_Real_Literal then + Do_Multiply_Fixed_Universal (N, Left, Right); + + elsif Nkind (Right) = N_Type_Conversion then + Rewrite_Non_Static_Universal (Right); + Do_Multiply_Fixed_Fixed (N); + end if; + + else + Do_Multiply_Fixed_Fixed (N); + end if; + end Expand_Multiply_Fixed_By_Fixed_Giving_Fixed; + + ------------------------------------------------- + -- Expand_Multiply_Fixed_By_Fixed_Giving_Float -- + ------------------------------------------------- + + -- The multiply is done in Universal_Real, and the result is multiplied + -- by the adjustment for the smalls which is Small (Right) * Small (Left). + -- Special treatment is required for universal operands. + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Float (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + Left_Type : constant Entity_Id := Etype (Left); + Right_Type : constant Entity_Id := Etype (Right); + + begin + -- Case of left operand is universal real, the result we want is + + -- Left_Value * (Right_Value * Right_Small) + + -- so we compute this as: + + -- (Left_Value * Right_Small) * Right_Value; + + if Left_Type = Universal_Real then + Set_Result (N, + Build_Multiply (N, + Real_Literal (N, Realval (Left) * Small_Value (Right_Type)), + Fpt_Value (Right))); + + -- Case of right operand is universal real, the result we want is + + -- (Left_Value * Left_Small) * Right_Value + + -- so we compute this as: + + -- Left_Value * (Left_Small * Right_Value) + + elsif Right_Type = Universal_Real then + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Left), + Real_Literal (N, Small_Value (Left_Type) * Realval (Right)))); + + -- Both operands are fixed, so the value we want is + + -- (Left_Value * Left_Small) * (Right_Value * Right_Small) + + -- which we compute as: + + -- (Left_Value * Right_Value) * (Right_Small * Left_Small) + + else + Set_Result (N, + Build_Multiply (N, + Build_Multiply (N, Fpt_Value (Left), Fpt_Value (Right)), + Real_Literal (N, + Small_Value (Right_Type) * Small_Value (Left_Type)))); + end if; + end Expand_Multiply_Fixed_By_Fixed_Giving_Float; + + --------------------------------------------------- + -- Expand_Multiply_Fixed_By_Fixed_Giving_Integer -- + --------------------------------------------------- + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + begin + if Etype (Left) = Universal_Real then + Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left); + + elsif Etype (Right) = Universal_Real then + Do_Multiply_Fixed_Universal (N, Left, Right); + + -- If both types are equal and we need to avoid floating point + -- instructions, it's worth introducing a temporary with the + -- common type, because it may be evaluated more simply without + -- the need for run-time use of floating point. + + elsif Etype (Right) = Etype (Left) + and then Restriction_Active (No_Floating_Point) + then + declare + Temp : constant Entity_Id := Make_Temporary (Loc, 'F'); + Mult : constant Node_Id := Make_Op_Multiply (Loc, Left, Right); + Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Etype (Right), Loc), + Expression => Mult); + + begin + Insert_Action (N, Decl); + Rewrite (N, + OK_Convert_To (Etype (N), New_Occurrence_Of (Temp, Loc))); + Analyze_And_Resolve (N, Standard_Integer); + end; + + else + Do_Multiply_Fixed_Fixed (N); + end if; + end Expand_Multiply_Fixed_By_Fixed_Giving_Integer; + + --------------------------------------------------- + -- Expand_Multiply_Fixed_By_Integer_Giving_Fixed -- + --------------------------------------------------- + + -- Since the operand and result fixed-point type is the same, this is + -- a straight multiply by the right operand, the small can be ignored. + + procedure Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N : Node_Id) is + begin + Set_Result (N, + Build_Multiply (N, Left_Opnd (N), Right_Opnd (N))); + end Expand_Multiply_Fixed_By_Integer_Giving_Fixed; + + --------------------------------------------------- + -- Expand_Multiply_Integer_By_Fixed_Giving_Fixed -- + --------------------------------------------------- + + -- Since the operand and result fixed-point type is the same, this is + -- a straight multiply by the right operand, the small can be ignored. + + procedure Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N : Node_Id) is + begin + Set_Result (N, + Build_Multiply (N, Left_Opnd (N), Right_Opnd (N))); + end Expand_Multiply_Integer_By_Fixed_Giving_Fixed; + + --------------- + -- Fpt_Value -- + --------------- + + function Fpt_Value (N : Node_Id) return Node_Id is + Typ : constant Entity_Id := Etype (N); + + begin + if Is_Integer_Type (Typ) + or else Is_Floating_Point_Type (Typ) + then + return Build_Conversion (N, Universal_Real, N); + + -- Fixed-point case, must get integer value first + + else + return Build_Conversion (N, Universal_Real, N); + end if; + end Fpt_Value; + + --------------------- + -- Integer_Literal -- + --------------------- + + function Integer_Literal + (N : Node_Id; + V : Uint; + Negative : Boolean := False) return Node_Id + is + T : Entity_Id; + L : Node_Id; + + begin + if V < Uint_2 ** 7 then + T := Standard_Integer_8; + + elsif V < Uint_2 ** 15 then + T := Standard_Integer_16; + + elsif V < Uint_2 ** 31 then + T := Standard_Integer_32; + + elsif V < Uint_2 ** 63 then + T := Standard_Integer_64; + + else + return Empty; + end if; + + if Negative then + L := Make_Integer_Literal (Sloc (N), UI_Negate (V)); + else + L := Make_Integer_Literal (Sloc (N), V); + end if; + + -- Set type of result in case used elsewhere (see note at start) + + Set_Etype (L, T); + Set_Is_Static_Expression (L); + + -- We really need to set Analyzed here because we may be creating a + -- very strange beast, namely an integer literal typed as fixed-point + -- and the analyzer won't like that. Probably we should allow the + -- Treat_Fixed_As_Integer flag to appear on integer literal nodes + -- and teach the analyzer how to handle them ??? + + Set_Analyzed (L); + return L; + end Integer_Literal; + + ------------------ + -- Real_Literal -- + ------------------ + + function Real_Literal (N : Node_Id; V : Ureal) return Node_Id is + L : Node_Id; + + begin + L := Make_Real_Literal (Sloc (N), V); + + -- Set type of result in case used elsewhere (see note at start) + + Set_Etype (L, Universal_Real); + return L; + end Real_Literal; + + ------------------------ + -- Rounded_Result_Set -- + ------------------------ + + function Rounded_Result_Set (N : Node_Id) return Boolean is + K : constant Node_Kind := Nkind (N); + begin + if (K = N_Type_Conversion or else + K = N_Op_Divide or else + K = N_Op_Multiply) + and then + (Rounded_Result (N) or else Is_Integer_Type (Etype (N))) + then + return True; + else + return False; + end if; + end Rounded_Result_Set; + + ---------------- + -- Set_Result -- + ---------------- + + procedure Set_Result + (N : Node_Id; + Expr : Node_Id; + Rchk : Boolean := False; + Trunc : Boolean := False) + is + Cnode : Node_Id; + + Expr_Type : constant Entity_Id := Etype (Expr); + Result_Type : constant Entity_Id := Etype (N); + + begin + -- No conversion required if types match and no range check or truncate + + if Result_Type = Expr_Type and then not (Rchk or Trunc) then + Cnode := Expr; + + -- Else perform required conversion + + else + Cnode := Build_Conversion (N, Result_Type, Expr, Rchk, Trunc); + end if; + + Rewrite (N, Cnode); + Analyze_And_Resolve (N, Result_Type); + end Set_Result; + +end Exp_Fixd;