Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / exp_fixd.adb < prev next >

Wrap

Text File | 1996-09-28 | 80KB | 2,262 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ F I X D -- -- -- -- B o d y -- -- -- -- $Revision: 1.38 $ -- -- -- -- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved -- -- -- -- 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 2, 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 COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Treepr; use Treepr; with Atree; use Atree; with Einfo; use Einfo; with Nlists; use Nlists; with Nmake; use Nmake; with Output; use Output; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; 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) return Node_Id; -- Build an expression that convers 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. 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 Long_Long_Float, in which case Build_Divide differs -- from Make_Op_Divide only in that the Etype of the resulting node is -- set (to Long_Long_Float), 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 Long_Long_Float, in which case Build_Divide differs -- from Make_Op_Multiply only in that the Etype of the resulting node is -- set (to Long_Long_Float), 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). function Fpt_Value (N : Node_Id) return Node_Id; -- Given an operand of fixed-point operation, return an expression that -- represents the corresponding Long_Long_Float 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 Long_Long_Float). function Integer_Literal (N : Node_Id; V : Uint) return Node_Id; -- Given a non-negative universal integer value, build a typed integer -- literal node, using the smallest applicable standard integer type. If -- the value 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 Long_Long_Float, since all floating-point -- arithmetic operations that we construct use Long_Long_Float 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. procedure Set_Result (N : Node_Id; Expr : Node_Id); -- 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. ---------------------- -- Build_Conversion -- ---------------------- function Build_Conversion (N : Node_Id; Typ : Entity_Id; Expr : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); Extyp : constant Entity_Id := Etype (Expr); Result : Node_Id; Intyp : Entity_Id; begin -- Remove inner conversion if both inner and outer conversions are to -- integer types, since the inner one serves no purpose (except perhaps -- to guarantee rounding, so we preserve the Rounded_Result flag) if Is_Integer_Type (Typ) and then Is_Integer_Type (Extyp) 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)); -- Another special case, if the expression is an integer literal -- and the target type is an integer type or fixed-oint type, then -- just retype the integer literal to the desired target type. elsif Nkind (Expr) = N_Integer_Literal and then (Is_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ)) then Result := 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 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 (Extyp) then Set_Conversion_OK (Result); 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 := Etype (L); Right_Type : constant Entity_Id := 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 = Standard_Long_Long_Float); pragma Assert (Right_Type = Standard_Long_Long_Float); Rnode := Make_Op_Divide (Loc, L, R); Result_Type := Standard_Long_Long_Float; -- Integer and fixed-point cases else -- An optimization. If the right operand is the literal 1, then we -- can just return the right 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 is 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 Int := UI_To_Int (Esize (Etype (Y))); Z_Size : constant Int := 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 Int'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; begin Build_Double_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code); Expr := Make_Expression_Actions (Loc, Actions => Code, Expression => 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 Int := UI_To_Int (Esize (Etype (X))); Y_Size : constant Int := UI_To_Int (Esize (Etype (Y))); Z_Size : constant Int := UI_To_Int (Esize (Etype (Z))); QR_Siz : Int; 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 := Int'Max (X_Size, 2 * Int'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_Defining_Identifier (Loc, New_Internal_Name ('S')); Rnn := Make_Defining_Identifier (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('N')); Dnn := Make_Defining_Identifier (Loc, New_Internal_Name ('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 if Rounded_Result_Set (N) then Rnd := Standard_True; else Rnd := Standard_False; end if; 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); 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 = Standard_Long_Long_Float); pragma Assert (Right_Type = Standard_Long_Long_Float); Result_Type := Standard_Long_Long_Float; 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 use a type that is at least twice the longer -- of the two sizes. Rsize := 2 * Int'Max (UI_To_Int (Esize (Left_Type)), UI_To_Int (Esize (Right_Type))); 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 Int := UI_To_Int (Esize (Etype (X))); Y_Size : constant Int := 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 Int'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; begin Build_Scaled_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code); Expr := Make_Expression_Actions (Loc, Actions => Code, Expression => 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 Int := UI_To_Int (Esize (Etype (X))); Y_Size : constant Int := UI_To_Int (Esize (Etype (Y))); Z_Size : constant Int := UI_To_Int (Esize (Etype (Z))); QR_Siz : Int; 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 := Int'Max (X_Size, 2 * Int'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_Defining_Identifier (Loc, New_Internal_Name ('S')); Rnn := Make_Defining_Identifier (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('N')); Dnn := Make_Defining_Identifier (Loc, New_Internal_Name ('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 if Rounded_Result_Set (N) then Rnd := Standard_True; else Rnd := Standard_False; end if; 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 -- 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); 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); 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); 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); Lit_K := Integer_Literal (N, Frac_Den); 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); 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); Lit_K := Integer_Literal (N, Frac_Num); if Present (Lit_Int) and then Present (Lit_K) then Set_Result (N, Build_Scaled_Divide (N, Right, 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 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); 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); 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); Right_Type : constant Entity_Id := Etype (Right); 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); 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); 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_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 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 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)); 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))); 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 Long_Long_Float, and then -- convert the result to the target floating-point type. procedure Expand_Convert_Fixed_To_Float (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Expr : constant Node_Id := Expression (N); Result_Type : constant Entity_Id := Etype (N); Source_Type : constant Entity_Id := Etype (Expr); Small : constant Ureal := Small_Value (Source_Type); begin if Small = Ureal_1 then Set_Result (N, Expr); else Set_Result (N, Build_Multiply (N, Fpt_Value (Expr), Real_Literal (N, Small))); 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 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 Small_Den = 1 then Lit := Integer_Literal (N, Small_Num); if Present (Lit) then Set_Result (N, Build_Multiply (N, Expr, Lit)); 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)); 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))); 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); Result_Type : constant Entity_Id := Etype (N); Small : constant Ureal := Small_Value (Result_Type); begin -- Optimize small = 1, where we can avoid the multiply completely if Small = Ureal_1 then Set_Result (N, Expr); -- Normal case where multiply is required else Set_Result (N, Build_Multiply (N, Fpt_Value (Expr), Real_Literal (N, Ureal_1 / Small))); 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 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)); 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)); 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))); 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 => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Quotient_Type, Loc), Expression => 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 => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Remainder_Type, Loc), Expression => Adjusted_Remainder))); -- Final step is to rewrite the call with a block containing the -- above sequence of constructed statements for the divide operation. Rewrite_Substitute_Tree (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 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_Fixed; ----------------------------------------------- -- Expand_Divide_Fixed_By_Fixed_Giving_Float -- ----------------------------------------------- -- The division is done in long_long_float, 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); Result_Type : constant Entity_Id := Etype (N); 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); begin if Etype (Left) = Universal_Real then Do_Multiply_Fixed_Universal (N, Right, Left); elsif Etype (Right) = Universal_Real then Do_Multiply_Fixed_Universal (N, Left, Right); 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 long_long_float, 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); Result_Type : constant Entity_Id := Etype (N); 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 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, Right, Left); elsif Etype (Right) = Universal_Real then Do_Multiply_Fixed_Universal (N, Left, Right); 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, Standard_Long_Long_Float, N); -- Fixed-point case, must get integer value first else return Build_Conversion (N, Standard_Long_Long_Float, N); end if; end Fpt_Value; --------------------- -- Integer_Literal -- --------------------- function Integer_Literal (N : Node_Id; V : Uint) 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; L := Make_Integer_Literal (Sloc (N), V); -- 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, Standard_Long_Long_Float); 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) then return True; else return False; end if; end Rounded_Result_Set; ---------------- -- Set_Result -- ---------------- procedure Set_Result (N : Node_Id; Expr : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Cnode : Node_Id; Expr_Type : constant Entity_Id := Etype (Expr); Result_Type : constant Entity_Id := Etype (N); Itype : Entity_Id; begin -- No conversion required if types match if Result_Type = Expr_Type then Cnode := Expr; -- Else perform required conversion else Cnode := Build_Conversion (N, Result_Type, Expr); end if; Rewrite_Substitute_Tree (N, Cnode); Analyze (N); Resolve (N, Result_Type); end Set_Result; end Exp_Fixd;