Commit d26d790d by Arnaud Charlet

[multiple changes]

2014-08-04  Robert Dewar  <dewar@adacore.com>

	* checks.adb (Activate_Overflow_Check): Remove
	Check_Float_Overflow processing.
	(Apply_Scalar_Range_Check): Ditto.
	(Generate_Range_Check): Ditto.
	* exp_ch4.adb (Expand_N_Op_Add): Add call to
	Check_Float_Op_Overflow.
	(Expand_N_Op_Divide): ditto.
	(Expand_N_Op_Multiply): ditto.
	(Expand_N_Op_Subtract): ditto.
	* exp_util.ads, exp_util.adb (Check_Float_Op_Overflow): New procedure.
	* sem_attr.adb (Analyze_Attribute, case Pred): Make sure
	Do_Range_Check is set for floating-point case in -gnatc or
	GNATprove mode.
	(Analyze_Attribute, case Succ): Make sure
	Do_Range_Check is set for floating-point case in -gnatc or
	GNATprove mode.
	* sem_res.adb (Resolve_Type_Conversion): Make sure Do_Range_Check
	flag is set for real to integer conversion in GNATprove or
	-gnatc mode.

2014-08-04  Gary Dismukes  <dismukes@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications): Resolve
	the expression of an Import or Export aspect as type Boolean
	and require it to be static. Add ??? comment. Also, set the
	Is_Exported flag when appropriate.

From-SVN: r213545
parent d478ac59
2014-08-04 Robert Dewar <dewar@adacore.com> 2014-08-04 Robert Dewar <dewar@adacore.com>
* checks.adb (Activate_Overflow_Check): Remove
Check_Float_Overflow processing.
(Apply_Scalar_Range_Check): Ditto.
(Generate_Range_Check): Ditto.
* exp_ch4.adb (Expand_N_Op_Add): Add call to
Check_Float_Op_Overflow.
(Expand_N_Op_Divide): ditto.
(Expand_N_Op_Multiply): ditto.
(Expand_N_Op_Subtract): ditto.
* exp_util.ads, exp_util.adb (Check_Float_Op_Overflow): New procedure.
* sem_attr.adb (Analyze_Attribute, case Pred): Make sure
Do_Range_Check is set for floating-point case in -gnatc or
GNATprove mode.
(Analyze_Attribute, case Succ): Make sure
Do_Range_Check is set for floating-point case in -gnatc or
GNATprove mode.
* sem_res.adb (Resolve_Type_Conversion): Make sure Do_Range_Check
flag is set for real to integer conversion in GNATprove or
-gnatc mode.
2014-08-04 Gary Dismukes <dismukes@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): Resolve
the expression of an Import or Export aspect as type Boolean
and require it to be static. Add ??? comment. Also, set the
Is_Exported flag when appropriate.
2014-08-04 Robert Dewar <dewar@adacore.com>
* exp_ch4.adb: Minor reformatting. * exp_ch4.adb: Minor reformatting.
* exp_attr.adb: Minor reformatting. * exp_attr.adb: Minor reformatting.
......
...@@ -396,10 +396,6 @@ package body Checks is ...@@ -396,10 +396,6 @@ package body Checks is
if Present (Etype (N)) if Present (Etype (N))
and then Is_Floating_Point_Type (Etype (N)) and then Is_Floating_Point_Type (Etype (N))
and then not Is_Constrained (Etype (N)) and then not Is_Constrained (Etype (N))
-- But do the check after all if float overflow checking enforced
and then not Check_Float_Overflow
then then
return; return;
end if; end if;
...@@ -2871,11 +2867,6 @@ package body Checks is ...@@ -2871,11 +2867,6 @@ package body Checks is
and then not Has_Infinities (Target_Typ) and then not Has_Infinities (Target_Typ)
then then
Enable_Range_Check (Expr); Enable_Range_Check (Expr);
-- Always do a range check for operators if option set
elsif Check_Float_Overflow and then Nkind (Expr) in N_Op then
Enable_Range_Check (Expr);
end if; end if;
end if; end if;
...@@ -2984,9 +2975,9 @@ package body Checks is ...@@ -2984,9 +2975,9 @@ package body Checks is
-- Normally, we only do range checks if the type is constrained. We do -- Normally, we only do range checks if the type is constrained. We do
-- NOT want range checks for unconstrained types, since we want to have -- NOT want range checks for unconstrained types, since we want to have
-- infinities. Override this decision in Check_Float_Overflow mode. -- infinities.
if Is_Constrained (S_Typ) or else Check_Float_Overflow then if Is_Constrained (S_Typ) then
Enable_Range_Check (Expr); Enable_Range_Check (Expr);
end if; end if;
...@@ -6471,11 +6462,6 @@ package body Checks is ...@@ -6471,11 +6462,6 @@ package body Checks is
or else or else
(Is_Entity_Name (N) (Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Enumeration_Literal)) and then Ekind (Entity (N)) = E_Enumeration_Literal))
-- Also do not apply this for floating-point if Check_Float_Overflow
and then not
(Is_Floating_Point_Type (Source_Type) and Check_Float_Overflow)
then then
Set_Do_Range_Check (N, False); Set_Do_Range_Check (N, False);
return; return;
......
...@@ -151,11 +151,11 @@ package body Exp_Ch4 is ...@@ -151,11 +151,11 @@ package body Exp_Ch4 is
Bodies : List_Id) return Node_Id; Bodies : List_Id) return Node_Id;
-- Local recursive function used to expand equality for nested composite -- Local recursive function used to expand equality for nested composite
-- types. Used by Expand_Record/Array_Equality, Bodies is a list on which -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
-- to attach bodies of local functions that are created in the process. -- to attach bodies of local functions that are created in the process. It
-- It is the responsibility of the caller to insert those bodies at the -- is the responsibility of the caller to insert those bodies at the right
-- right place. Nod provides the Sloc value for generated code. Lhs and Rhs -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are
-- are the left and right sides for the comparison, and Typ is the type of -- the left and right sides for the comparison, and Typ is the type of the
-- the objects to compare. -- objects to compare.
procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id); procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
-- Routine to expand concatenation of a sequence of two or more operands -- Routine to expand concatenation of a sequence of two or more operands
......
...@@ -1633,6 +1633,60 @@ package body Exp_Util is ...@@ -1633,6 +1633,60 @@ package body Exp_Util is
return Build_Task_Image_Function (Loc, Decls, Stats, Res); return Build_Task_Image_Function (Loc, Decls, Stats, Res);
end Build_Task_Record_Image; end Build_Task_Record_Image;
-----------------------------
-- Check_Float_Op_Overflow --
-----------------------------
procedure Check_Float_Op_Overflow (N : Node_Id) is
begin
-- Return if no check needed
if not Check_Float_Overflow
or else not Is_Floating_Point_Type (Etype (N))
then
return;
end if;
-- Otherwise we replace the expression by
-- do Tnn : constant ftype := expression;
-- constraint_error when not Tnn'Valid;
-- in Tnn;
declare
Loc : constant Source_Ptr := Sloc (N);
Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
Typ : constant Entity_Id := Etype (N);
begin
-- Prevent recursion
Set_Analyzed (N);
-- Do the rewrite to include the check
Rewrite (N,
Make_Expression_With_Actions (Loc,
Actions => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Tnn,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Constant_Present => True,
Expression => Relocate_Node (N)),
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Not (Loc,
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Tnn, Loc),
Attribute_Name => Name_Valid)),
Reason => CE_Overflow_Check_Failed)),
Expression => New_Occurrence_Of (Tnn, Loc)));
Analyze_And_Resolve (N, Typ);
end;
end Check_Float_Op_Overflow;
---------------------------------- ----------------------------------
-- Component_May_Be_Bit_Aligned -- -- Component_May_Be_Bit_Aligned --
---------------------------------- ----------------------------------
......
...@@ -276,6 +276,13 @@ package Exp_Util is ...@@ -276,6 +276,13 @@ package Exp_Util is
-- is false, the call is for a stand-alone object, and the generated -- is false, the call is for a stand-alone object, and the generated
-- function itself must do its own cleanups. -- function itself must do its own cleanups.
procedure Check_Float_Op_Overflow (N : Node_Id);
-- Called where we could have a floating-point binary operator where we
-- must check for infinities if we are operating in Check_Float_Overflow
-- mode. Note that we don't need to worry about unary operator cases,
-- since for floating-point, abs, unary "-", and unary "+" can never
-- case overflow.
function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean; function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean;
-- This function is in charge of detecting record components that may -- This function is in charge of detecting record components that may
-- cause trouble in the back end if an attempt is made to assign the -- cause trouble in the back end if an attempt is made to assign the
......
...@@ -4808,10 +4808,8 @@ package body Sem_Attr is ...@@ -4808,10 +4808,8 @@ package body Sem_Attr is
-- make an exception in Check_Float_Overflow mode. -- make an exception in Check_Float_Overflow mode.
if Is_Floating_Point_Type (P_Type) then if Is_Floating_Point_Type (P_Type) then
if Check_Float_Overflow if not Range_Checks_Suppressed (P_Base_Type) then
and then not Range_Checks_Suppressed (P_Base_Type) Set_Do_Range_Check (E1);
then
Enable_Range_Check (E1);
end if; end if;
-- If not modular type, test for overflow check required -- If not modular type, test for overflow check required
...@@ -5702,10 +5700,8 @@ package body Sem_Attr is ...@@ -5702,10 +5700,8 @@ package body Sem_Attr is
-- make an exception in Check_Float_Overflow mode. -- make an exception in Check_Float_Overflow mode.
if Is_Floating_Point_Type (P_Type) then if Is_Floating_Point_Type (P_Type) then
if Check_Float_Overflow if not Range_Checks_Suppressed (P_Base_Type) then
and then not Range_Checks_Suppressed (P_Base_Type) Set_Do_Range_Check (E1);
then
Enable_Range_Check (E1);
end if; end if;
-- If not modular type, test for overflow check required -- If not modular type, test for overflow check required
......
...@@ -2949,18 +2949,34 @@ package body Sem_Ch13 is ...@@ -2949,18 +2949,34 @@ package body Sem_Ch13 is
-- that verifed that there was a matching convention -- that verifed that there was a matching convention
-- is now obsolete. -- is now obsolete.
if A_Id = Aspect_Import then -- Resolve the expression of an Import or Export here,
Set_Is_Imported (E); -- and require it to be of type Boolean and static. This
-- is not quite right, because in general this should be
-- delayed, but that seems tricky for these, because
-- normally Boolean aspects are replaced with pragmas at
-- the freeze point (in Make_Pragma_From_Boolean_Aspect),
-- but in the case of these aspects we can't generate
-- a simple pragma with just the entity name. ???
if not Present (Expr)
or else Is_True (Static_Boolean (Expr))
then
if A_Id = Aspect_Import then
Set_Is_Imported (E);
-- An imported entity cannot have an explicit -- An imported entity cannot have an explicit
-- initialization. -- initialization.
if Nkind (N) = N_Object_Declaration if Nkind (N) = N_Object_Declaration
and then Present (Expression (N)) and then Present (Expression (N))
then then
Error_Msg_N Error_Msg_N
("imported entities cannot be initialized " ("imported entities cannot be initialized "
& "(RM B.1(24))", Expression (N)); & "(RM B.1(24))", Expression (N));
end if;
elsif A_Id = Aspect_Export then
Set_Is_Exported (E);
end if; end if;
end if; end if;
......
...@@ -10507,9 +10507,11 @@ package body Sem_Res is ...@@ -10507,9 +10507,11 @@ package body Sem_Res is
-- If at this stage we have a real to integer conversion, make sure -- If at this stage we have a real to integer conversion, make sure
-- that the Do_Range_Check flag is set, because such conversions in -- that the Do_Range_Check flag is set, because such conversions in
-- general need a range check. -- general need a range check. We only need this if expansion is off
-- or we are in GNATProve mode.
if Nkind (N) = N_Type_Conversion if Nkind (N) = N_Type_Conversion
and then (GNATprove_Mode or not Expander_Active)
and then Is_Integer_Type (Target_Typ) and then Is_Integer_Type (Target_Typ)
and then Is_Real_Type (Operand_Typ) and then Is_Real_Type (Operand_Typ)
then then
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment