-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- 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) return Node_Id;
+ (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.
+ -- 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
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_Divide differs from
+ -- 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
-- 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);
+ 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-
-- (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 is True, then Do_Range_Check is
- -- set in the resulting conversion.
+ -- 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) return Node_Id
+ (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;
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
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);
-- 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 in 8 or 16 bits.
-
- -- Note: if both operands are known at compile time (can that
- -- happen?) and both were equal to the power of 2, then we would
- -- be one bit off in this test, so for the left operand, we only
- -- go up to the power of 2 - 1. This ensures that we do not get
- -- this anomolous case, and in practice the right operand is by
- -- far the more likely one to be the constant.
+ -- 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 ** 8) then
+ if Val < Int'(2 ** 7) then
Left_Size := 8;
- elsif Val < Int'(2 ** 16) then
+ elsif Val < Int'(2 ** 15) then
Left_Size := 16;
end if;
end;
if Compile_Time_Known_Value (R) then
declare
Val : constant Uint := Expr_Value (R);
-
begin
- if Val <= Int'(2 ** 8) then
+ if Val <= Int'(2 ** 7) then
Right_Size := 8;
- elsif Val <= Int'(2 ** 16) then
+ 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 accomodate all possible results.
+ -- the two sizes, to accommodate all possible results.
Rsize := 2 * Int'Max (Left_Size, Right_Size);
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);
-- Optimize small = 1, where we can avoid the multiply completely
if Small = Ureal_1 then
- Set_Result (N, Expr, Rng_Check);
+ 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).
else
Set_Result (N,
Build_Multiply (N,
Fpt_Value (Expr),
Real_Literal (N, Ureal_1 / Small)),
- Rng_Check);
+ Rng_Check, Trunc => Is_Decimal_Fixed_Point_Type (Result_Type));
end if;
end Expand_Convert_Float_To_Fixed;
if Etype (Left) = Universal_Real then
if Nkind (Left) = N_Real_Literal then
- Do_Multiply_Fixed_Universal (N, Right, Left);
+ Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left);
elsif Nkind (Left) = N_Type_Conversion then
Rewrite_Non_Static_Universal (Left);
Right : constant Node_Id := Right_Opnd (N);
begin
if Etype (Left) = Universal_Real then
- Do_Multiply_Fixed_Universal (N, Right, Left);
+ Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left);
elsif Etype (Right) = Universal_Real then
Do_Multiply_Fixed_Universal (N, Left, Right);
else
----------------
procedure Set_Result
- (N : Node_Id;
- Expr : Node_Id;
- Rchk : Boolean := False)
+ (N : Node_Id;
+ Expr : Node_Id;
+ Rchk : Boolean := False;
+ Trunc : Boolean := False)
is
Cnode : Node_Id;
Result_Type : constant Entity_Id := Etype (N);
begin
- -- No conversion required if types match and no range check
+ -- No conversion required if types match and no range check or truncate
- if Result_Type = Expr_Type and then not Rchk then
+ 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);
+ Cnode := Build_Conversion (N, Result_Type, Expr, Rchk, Trunc);
end if;
Rewrite (N, Cnode);
OSDN Git Service
