[multiple changes]

2014-08-04  Vincent Celier  <celier@adacore.com>

	* prj-dect.adb (Parse_Case_Construction): It is no longer
	an error if the variable for a case construction is not
	typed, only if the variable value is not a single string. Call
	Parse_Choice_List and End_Case_Construction with the new parameter
	to indicate that the variable is typed.
	* prj-strt.adb (End_Case_Construction): Only check the labels
	if the variable is typed.  If the variable is not typed,
	issue a warning when there is no "when others" allternative.
	(Parse_Choice_List): Manage the labels only if the variable
	is typed.
	* prj-strt.ads (End_Case_Construction): New Boolean parameter
	String_Type.
	(Parse_Choice_List): Ditto.

2014-08-04  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch5.adb: Additional fix to Check_Predicate_Use.

2014-08-04  Vincent Celier  <celier@adacore.com>

	* projects.texi: Update documentation of case constructions with
	variables that are not typed.

2014-08-04  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Build_Class_Wide_Wrapper): If the operator carries
	an Eliminated pragma, indicate that the wrapper is also to be
	eliminated, to prevent spurious errors when using gnatelim on
	programs that include box-initialization of equality operators
	(consequence of AI05-071)..

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

	* checks.adb (Activate_Overflow_Check): Handle floating-point
	case correctly.
	* checks.ads (Activate_Overflow_Check): Clarify handling of
	floating-point cases.
	* exp_util.adb (Check_Float_Op_Overflow): Reset Do_Overflow_Check
	flag if we generate an explicit overflow check (for
	Check_Float_Overflow mode).

From-SVN: r213550
This commit is contained in:
Arnaud Charlet 2014-08-04 11:57:00 +02:00
parent 7ed571892e
commit bb30428734
10 changed files with 201 additions and 96 deletions

View File

@ -1,3 +1,46 @@
2014-08-04 Vincent Celier <celier@adacore.com>
* prj-dect.adb (Parse_Case_Construction): It is no longer
an error if the variable for a case construction is not
typed, only if the variable value is not a single string. Call
Parse_Choice_List and End_Case_Construction with the new parameter
to indicate that the variable is typed.
* prj-strt.adb (End_Case_Construction): Only check the labels
if the variable is typed. If the variable is not typed,
issue a warning when there is no "when others" allternative.
(Parse_Choice_List): Manage the labels only if the variable
is typed.
* prj-strt.ads (End_Case_Construction): New Boolean parameter
String_Type.
(Parse_Choice_List): Ditto.
2014-08-04 Ed Schonberg <schonberg@adacore.com>
* sem_ch5.adb: Additional fix to Check_Predicate_Use.
2014-08-04 Vincent Celier <celier@adacore.com>
* projects.texi: Update documentation of case constructions with
variables that are not typed.
2014-08-04 Ed Schonberg <schonberg@adacore.com>
* sem_ch8.adb (Build_Class_Wide_Wrapper): If the operator carries
an Eliminated pragma, indicate that the wrapper is also to be
eliminated, to prevent spurious errors when using gnatelim on
programs that include box-initialization of equality operators
(consequence of AI05-071)..
2014-08-04 Robert Dewar <dewar@adacore.com>
* checks.adb (Activate_Overflow_Check): Handle floating-point
case correctly.
* checks.ads (Activate_Overflow_Check): Clarify handling of
floating-point cases.
* exp_util.adb (Check_Float_Op_Overflow): Reset Do_Overflow_Check
flag if we generate an explicit overflow check (for
Check_Float_Overflow mode).
2014-08-04 Robert Dewar <dewar@adacore.com> 2014-08-04 Robert Dewar <dewar@adacore.com>
* prj-proc.adb, prj-part.adb, prj-strt.adb, prj.adb, prj.ads, * prj-proc.adb, prj-part.adb, prj-strt.adb, prj.adb, prj.ads,

View File

@ -388,27 +388,46 @@ package body Checks is
----------------------------- -----------------------------
procedure Activate_Overflow_Check (N : Node_Id) is procedure Activate_Overflow_Check (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin begin
-- Nothing to do for unconstrained floating-point types (the test for -- Floating-point case. If Etype is not set (this can happen when we
-- Etype (N) being present seems necessary in some cases, should be -- activate a check on a node that has not yet been analyzed), then
-- tracked down, but for now just ignore the check in this case ???), -- we assume we do not have a floating-point type (as per our spec).
-- except if Check_Float_Overflow is set.
if Present (Etype (N)) if Present (Typ) and then Is_Floating_Point_Type (Typ) then
and then Is_Floating_Point_Type (Etype (N))
and then not Is_Constrained (Etype (N)) -- Ignore call if we have no automatic overflow checks on the target
and then not Check_Float_Overflow -- and Check_Float_Overflow mode is not set. These are the cases in
then -- which we expect to generate infinities and NaN's with no check.
return;
if not (Machine_Overflows_On_Target or Check_Float_Overflow) then
return;
-- Ignore for unary operations ("+", "-", abs) since these can never
-- result in overflow for floating-point cases.
elsif Nkind (N) in N_Unary_Op then
return;
-- Otherwise we will set the flag
else
null;
end if;
-- Discrete case
else
-- Nothing to do for Rem/Mod/Plus (overflow not possible, the check
-- for zero-divide is a divide check, not an overflow check).
if Nkind_In (N, N_Op_Rem, N_Op_Mod, N_Op_Plus) then
return;
end if;
end if; end if;
-- Nothing to do for Rem/Mod/Plus (overflow not possible) -- Fall through for cases where we do set the flag
if Nkind_In (N, N_Op_Rem, N_Op_Mod, N_Op_Plus) then
return;
end if;
-- Otherwise set the flag
Set_Do_Overflow_Check (N, True); Set_Do_Overflow_Check (N, True);
Possible_Local_Raise (N, Standard_Constraint_Error); Possible_Local_Raise (N, Standard_Constraint_Error);

View File

@ -145,10 +145,19 @@ package Checks is
-- Sets Do_Overflow_Check flag in node N, and handles possible local raise. -- Sets Do_Overflow_Check flag in node N, and handles possible local raise.
-- Always call this routine rather than calling Set_Do_Overflow_Check to -- Always call this routine rather than calling Set_Do_Overflow_Check to
-- set an explicit value of True, to ensure handling the local raise case. -- set an explicit value of True, to ensure handling the local raise case.
-- Note that this call has no effect for MOD, REM, and unary "+" for which -- Note that for discrete types, this call has no effect for MOD, REM, and
-- overflow is never possible in any case. In addition, we do not set the -- unary "+" for which overflow is never possible in any case.
-- flag for unconstrained floating-point type operations, since we want to --
-- allow for the generation of IEEE infinities in such cases. -- Note: for the discrete-type case, it is legitimate to call this routine
-- on an unanalyzed node where the Etype field is not set. However, for the
-- floating-point case, Etype must be set (to a floating-point type).
--
-- For floating-point, we set the flag if we have automatic overflow checks
-- on the target, or if Check_Float_Overflow mode is set. For the floating-
-- point case, we ignore all the unary operators ("+", "-", and abs) since
-- none of these can result in overflow. If there are no overflow checks on
-- the target, and Check_Float_Overflow mode is not set, then the call has
-- no effect, since in such cases we want to generate NaN's and infinities.
procedure Activate_Range_Check (N : Node_Id); procedure Activate_Range_Check (N : Node_Id);
pragma Inline (Activate_Range_Check); pragma Inline (Activate_Range_Check);

View File

@ -1641,10 +1641,11 @@ package body Exp_Util is
begin begin
-- Return if no check needed -- Return if no check needed
if not Check_Float_Overflow if not Is_Floating_Point_Type (Etype (N))
or else not Is_Floating_Point_Type (Etype (N)) or else not (Do_Overflow_Check (N) and then Check_Float_Overflow)
-- In CodePeer_Mode, rely on the overflow check flag being set instead -- In CodePeer_Mode, rely on the overflow check flag being set instead
-- and do not expand the code for float overflow checking.
or else CodePeer_Mode or else CodePeer_Mode
then then
@ -1663,9 +1664,12 @@ package body Exp_Util is
Typ : constant Entity_Id := Etype (N); Typ : constant Entity_Id := Etype (N);
begin begin
-- Prevent recursion -- Turn off the Do_Overflow_Check flag, since we are doing that work
-- right here. We also set the node as analyzed to prevent infinite
-- recursion from repeating the operation in the expansion.
Set_Analyzed (N); Set_Do_Overflow_Check (N, False);
Set_Analyzed (N, True);
-- Do the rewrite to include the check -- Do the rewrite to include the check

View File

@ -827,11 +827,11 @@ package body Prj.Dect is
if Present (Case_Variable) then if Present (Case_Variable) then
String_Type := String_Type_Of (Case_Variable, In_Tree); String_Type := String_Type_Of (Case_Variable, In_Tree);
if No (String_Type) then if Expression_Kind_Of (Case_Variable, In_Tree) /= Single then
Error_Msg (Flags, Error_Msg (Flags,
"variable """ & "variable """ &
Get_Name_String (Name_Of (Case_Variable, In_Tree)) & Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
""" is not typed", """ is not a single string",
Variable_Location); Variable_Location);
end if; end if;
end if; end if;
@ -914,7 +914,8 @@ package body Prj.Dect is
Parse_Choice_List Parse_Choice_List
(In_Tree => In_Tree, (In_Tree => In_Tree,
First_Choice => First_Choice, First_Choice => First_Choice,
Flags => Flags); Flags => Flags,
String_Type => Present (String_Type));
Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice); Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
Expect (Tok_Arrow, "`=>`"); Expect (Tok_Arrow, "`=>`");
@ -941,7 +942,8 @@ package body Prj.Dect is
End_Case_Construction End_Case_Construction
(Check_All_Labels => not When_Others and not Quiet_Output, (Check_All_Labels => not When_Others and not Quiet_Output,
Case_Location => Location_Of (Case_Construction, In_Tree), Case_Location => Location_Of (Case_Construction, In_Tree),
Flags => Flags); Flags => Flags,
String_Type => Present (String_Type));
Expect (Tok_End, "`END CASE`"); Expect (Tok_End, "`END CASE`");
Remove_Next_End_Node; Remove_Next_End_Node;

View File

@ -297,7 +297,8 @@ package body Prj.Strt is
procedure End_Case_Construction procedure End_Case_Construction
(Check_All_Labels : Boolean; (Check_All_Labels : Boolean;
Case_Location : Source_Ptr; Case_Location : Source_Ptr;
Flags : Processing_Flags) Flags : Processing_Flags;
String_Type : Boolean)
is is
Non_Used : Natural := 0; Non_Used : Natural := 0;
First_Non_Used : Choice_Node_Id := First_Choice_Node_Id; First_Non_Used : Choice_Node_Id := First_Choice_Node_Id;
@ -306,7 +307,8 @@ package body Prj.Strt is
-- of the string type have been used. -- of the string type have been used.
if Check_All_Labels then if Check_All_Labels then
for Choice in Choice_First .. Choices.Last loop if String_Type then
for Choice in Choice_First .. Choices.Last loop
if not Choices.Table (Choice).Already_Used then if not Choices.Table (Choice).Already_Used then
Non_Used := Non_Used + 1; Non_Used := Non_Used + 1;
@ -314,27 +316,35 @@ package body Prj.Strt is
First_Non_Used := Choice; First_Non_Used := Choice;
end if; end if;
end if; end if;
end loop;
-- If only one is not used, report a single warning for this value
if Non_Used = 1 then
Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String;
Error_Msg (Flags, "?value %% is not used as label", Case_Location);
-- If several are not used, report a warning for each one of them
elsif Non_Used > 1 then
Error_Msg
(Flags, "?the following values are not used as labels:",
Case_Location);
for Choice in First_Non_Used .. Choices.Last loop
if not Choices.Table (Choice).Already_Used then
Error_Msg_Name_1 := Choices.Table (Choice).The_String;
Error_Msg (Flags, "\?%%", Case_Location);
end if;
end loop; end loop;
-- If only one is not used, report a single warning for this value
if Non_Used = 1 then
Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String;
Error_Msg
(Flags, "?value %% is not used as label", Case_Location);
-- If several are not used, report a warning for each one of
-- them.
elsif Non_Used > 1 then
Error_Msg
(Flags, "?the following values are not used as labels:",
Case_Location);
for Choice in First_Non_Used .. Choices.Last loop
if not Choices.Table (Choice).Already_Used then
Error_Msg_Name_1 := Choices.Table (Choice).The_String;
Error_Msg (Flags, "\?%%", Case_Location);
end if;
end loop;
end if;
else
Error_Msg
(Flags,
"?no when others for this case construction",
Case_Location);
end if; end if;
end if; end if;
@ -487,7 +497,8 @@ package body Prj.Strt is
procedure Parse_Choice_List procedure Parse_Choice_List
(In_Tree : Project_Node_Tree_Ref; (In_Tree : Project_Node_Tree_Ref;
First_Choice : out Project_Node_Id; First_Choice : out Project_Node_Id;
Flags : Processing_Flags) Flags : Processing_Flags;
String_Type : Boolean := True)
is is
Current_Choice : Project_Node_Id := Empty_Node; Current_Choice : Project_Node_Id := Empty_Node;
Next_Choice : Project_Node_Id := Empty_Node; Next_Choice : Project_Node_Id := Empty_Node;
@ -517,38 +528,40 @@ package body Prj.Strt is
Set_String_Value_Of (Current_Choice, In_Tree, To => Choice_String); Set_String_Value_Of (Current_Choice, In_Tree, To => Choice_String);
-- Check if the label is part of the string type and if it has not if String_Type then
-- been already used. -- Check if the label is part of the string type and if it has not
-- been already used.
Found := False; Found := False;
for Choice in Choice_First .. Choices.Last loop for Choice in Choice_First .. Choices.Last loop
if Choices.Table (Choice).The_String = Choice_String then if Choices.Table (Choice).The_String = Choice_String then
-- This label is part of the string type -- This label is part of the string type
Found := True; Found := True;
if Choices.Table (Choice).Already_Used then if Choices.Table (Choice).Already_Used then
-- But it has already appeared in a choice list for this -- But it has already appeared in a choice list for this
-- case construction so report an error. -- case construction so report an error.
Error_Msg_Name_1 := Choice_String; Error_Msg_Name_1 := Choice_String;
Error_Msg (Flags, "duplicate case label %%", Token_Ptr); Error_Msg (Flags, "duplicate case label %%", Token_Ptr);
else else
Choices.Table (Choice).Already_Used := True; Choices.Table (Choice).Already_Used := True;
end if;
exit;
end if; end if;
end loop;
exit; -- If the label is not part of the string list, report an error
if not Found then
Error_Msg_Name_1 := Choice_String;
Error_Msg (Flags, "illegal case label %%", Token_Ptr);
end if; end if;
end loop;
-- If the label is not part of the string list, report an error
if not Found then
Error_Msg_Name_1 := Choice_String;
Error_Msg (Flags, "illegal case label %%", Token_Ptr);
end if; end if;
-- Scan past the label -- Scan past the label

View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -59,7 +59,8 @@ private package Prj.Strt is
procedure End_Case_Construction procedure End_Case_Construction
(Check_All_Labels : Boolean; (Check_All_Labels : Boolean;
Case_Location : Source_Ptr; Case_Location : Source_Ptr;
Flags : Processing_Flags); Flags : Processing_Flags;
String_Type : Boolean);
-- This procedure is called at the end of a case construction to remove the -- This procedure is called at the end of a case construction to remove the
-- case labels and to restore the previous state. In particular, in the -- case labels and to restore the previous state. In particular, in the
-- case of nested case constructions, the case labels of the enclosing case -- case of nested case constructions, the case labels of the enclosing case
@ -70,7 +71,8 @@ private package Prj.Strt is
procedure Parse_Choice_List procedure Parse_Choice_List
(In_Tree : Project_Node_Tree_Ref; (In_Tree : Project_Node_Tree_Ref;
First_Choice : out Project_Node_Id; First_Choice : out Project_Node_Id;
Flags : Processing_Flags); Flags : Processing_Flags;
String_Type : Boolean := True);
-- Get the label for a choice list. -- Get the label for a choice list.
-- Report an error if -- Report an error if
-- - a case label is not a literal string -- - a case label is not a literal string

View File

@ -2403,7 +2403,7 @@ The environment variables at the time you launch @command{gprbuild}
will influence the view these tools have of the project will influence the view these tools have of the project
(PATH to find the compiler, ADA_PROJECT_PATH or GPR_PROJECT_PATH to find the (PATH to find the compiler, ADA_PROJECT_PATH or GPR_PROJECT_PATH to find the
projects, environment variables that are referenced in project files projects, environment variables that are referenced in project files
through the "external" statement,...). Several command line switches through the "external" built-in function, ...). Several command line switches
can be used to override those (-X or -aP), but on some systems and can be used to override those (-X or -aP), but on some systems and
with some projects, this might make the command line too long, and on with some projects, this might make the command line too long, and on
all systems often make it hard to read. all systems often make it hard to read.
@ -2427,7 +2427,7 @@ building. The syntax looks like
@end smallexample @end smallexample
One of the often requested features in projects is to be able to One of the often requested features in projects is to be able to
reference external variables in @code{with} statements, as in reference external variables in @code{with} declarations, as in
@smallexample @c projectfile @smallexample @c projectfile
@b{with} @b{external}("SETUP") & "path/prj.gpr"; --@i{ ILLEGAL} @b{with} @b{external}("SETUP") & "path/prj.gpr"; --@i{ ILLEGAL}
@ -2566,7 +2566,7 @@ Here are a few valid examples:
@cindex @code{Project_Path} @cindex @code{Project_Path}
This attribute can be used to specify a list of directories in This attribute can be used to specify a list of directories in
which to look for project files in @code{with} statements. which to look for project files in @code{with} declarations.
When you specify a project in Project_Files (say @code{x/y/a.gpr}), and When you specify a project in Project_Files (say @code{x/y/a.gpr}), and
@code{a.gpr} imports a project @code{b.gpr}, only @code{b.gpr} is searched in @code{a.gpr} imports a project @code{b.gpr}, only @code{b.gpr} is searched in
@ -2637,7 +2637,7 @@ Example:
@cindex @code{External} @cindex @code{External}
This attribute can be used to set the value of environment This attribute can be used to set the value of environment
variables as retrieved through the @code{external} statement variables as retrieved through the @code{external} function
in projects. It does not affect the environment variables in projects. It does not affect the environment variables
themselves (so for instance you cannot use it to change the value themselves (so for instance you cannot use it to change the value
of your PATH as seen from the spawned compiler). of your PATH as seen from the spawned compiler).
@ -3403,7 +3403,7 @@ list expression, and can therefore appear in a variable declaration or
an attribute declaration. an attribute declaration.
Most of the time, this construct is used to initialize typed variables, which Most of the time, this construct is used to initialize typed variables, which
are then used in @b{case} statements to control the value assigned to are then used in @b{case} constructions to control the value assigned to
attributes in various scenarios. Thus such variables are often called attributes in various scenarios. Thus such variables are often called
@b{scenario variables}. @b{scenario variables}.
@ -3565,8 +3565,8 @@ A @b{context} may be one of the following:
@c --------------------------------------------- @c ---------------------------------------------
@noindent @noindent
A @b{case} statement is used in a project file to effect conditional A @b{case} construction is used in a project file to effect conditional
behavior. Through this statement, you can set the value of attributes behavior. Through this construction, you can set the value of attributes
and variables depending on the value previously assigned to a typed and variables depending on the value previously assigned to a typed
variable. variable.
@ -3574,30 +3574,30 @@ All choices in a choice list must be distinct. Unlike Ada, the choice
lists of all alternatives do not need to include all values of the type. lists of all alternatives do not need to include all values of the type.
An @code{others} choice must appear last in the list of alternatives. An @code{others} choice must appear last in the list of alternatives.
The syntax of a @code{case} construction is based on the Ada case statement The syntax of a @code{case} construction is based on the Ada case construction
(although the @code{null} statement for empty alternatives is optional). (although the @code{null} declaration for empty alternatives is optional).
The case expression must be a typed string variable, whose value is often The case expression must be a string variable, either typed or not, whose value
given by an external reference (@pxref{External Values}). is often given by an external reference (@pxref{External Values}).
Each alternative starts with the reserved word @code{when}, either a list of Each alternative starts with the reserved word @code{when}, either a list of
literal strings separated by the @code{"|"} character or the reserved word literal strings separated by the @code{"|"} character or the reserved word
@code{others}, and the @code{"=>"} token. @code{others}, and the @code{"=>"} token.
Each literal string must belong to the string type that is the type of the When the case expression is a typed string variable, each literal string must
case variable. belong to the string type that is the type of the case variable.
After each @code{=>}, there are zero or more statements. The only After each @code{=>}, there are zero or more declarations. The only
statements allowed in a case construction are other case constructions, declarations allowed in a case construction are other case constructions,
attribute declarations and variable declarations. String type declarations and attribute declarations and variable declarations. String type declarations and
package declarations are not allowed. Variable declarations are restricted to package declarations are not allowed. Variable declarations are restricted to
variables that have already been declared before the case construction. variables that have already been declared before the case construction.
@smallexample @smallexample
case_statement ::= case_construction ::=
@i{case} @i{<typed_variable_>}name @i{is} @{case_item@} @i{end case} ; @i{case} @i{<variable_>}name @i{is} @{case_item@} @i{end case} ;
case_item ::= case_item ::=
@i{when} discrete_choice_list => @i{when} discrete_choice_list =>
@{case_statement @{case_declaration
| attribute_declaration | attribute_declaration
| variable_declaration | variable_declaration
| empty_declaration@} | empty_declaration@}
@ -3606,7 +3606,7 @@ discrete_choice_list ::= string_literal @{| string_literal@} | @i{others}
@end smallexample @end smallexample
@noindent @noindent
Here is a typical example: Here is a typical example, with a typed string variable:
@smallexample @c projectfile @smallexample @c projectfile
@group @group

View File

@ -2204,9 +2204,15 @@ package body Sem_Ch5 is
procedure Check_Predicate_Use (T : Entity_Id) is procedure Check_Predicate_Use (T : Entity_Id) is
begin begin
-- A predicated subtype is illegal in loops and related constructs
-- if the predicate is not static, or else if it is a non-static
-- subtype of a statically predicated subtype.
if Is_Discrete_Type (T) if Is_Discrete_Type (T)
and then Has_Predicates (T) and then Has_Predicates (T)
and then (not Has_Static_Predicate (T) and then (not Has_Static_Predicate (T)
or else not Is_Static_Subtype (T)
or else Has_Dynamic_Predicate_Aspect (T)) or else Has_Dynamic_Predicate_Aspect (T))
then then
Bad_Predicated_Subtype_Use Bad_Predicated_Subtype_Use

View File

@ -2321,6 +2321,13 @@ package body Sem_Ch8 is
Insert_Before_And_Analyze (N, Spec_Decl); Insert_Before_And_Analyze (N, Spec_Decl);
Wrap_Id := Defining_Entity (Spec_Decl); Wrap_Id := Defining_Entity (Spec_Decl);
-- If the operator carries an Eliminated pragma, indicate that the
-- wrapper is also to be eliminated, to prevent spurious error when
-- using gnatelim on programs that include box-initialization of
-- equality operators.
Set_Is_Eliminated (Wrap_Id, Is_Eliminated (Prim_Op));
-- The generated body does not freeze and must be analyzed when the -- The generated body does not freeze and must be analyzed when the
-- class-wide wrapper is frozen. The body is only needed if expansion -- class-wide wrapper is frozen. The body is only needed if expansion
-- is enabled. -- is enabled.