+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>
* prj-proc.adb, prj-part.adb, prj-strt.adb, prj.adb, prj.ads,
-----------------------------
procedure Activate_Overflow_Check (N : Node_Id) is
+ Typ : constant Entity_Id := Etype (N);
+
begin
- -- Nothing to do for unconstrained floating-point types (the test for
- -- Etype (N) being present seems necessary in some cases, should be
- -- tracked down, but for now just ignore the check in this case ???),
- -- except if Check_Float_Overflow is set.
-
- if Present (Etype (N))
- and then Is_Floating_Point_Type (Etype (N))
- and then not Is_Constrained (Etype (N))
- and then not Check_Float_Overflow
- then
- return;
- end if;
+ -- Floating-point case. If Etype is not set (this can happen when we
+ -- activate a check on a node that has not yet been analyzed), then
+ -- we assume we do not have a floating-point type (as per our spec).
- -- Nothing to do for Rem/Mod/Plus (overflow not possible)
+ if Present (Typ) and then Is_Floating_Point_Type (Typ) then
- if Nkind_In (N, N_Op_Rem, N_Op_Mod, N_Op_Plus) then
- return;
+ -- Ignore call if we have no automatic overflow checks on the target
+ -- and Check_Float_Overflow mode is not set. These are the cases in
+ -- which we expect to generate infinities and NaN's with no check.
+
+ 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;
- -- Otherwise set the flag
+ -- Fall through for cases where we do set the flag
Set_Do_Overflow_Check (N, True);
Possible_Local_Raise (N, Standard_Constraint_Error);
-- 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
-- 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
- -- overflow is never possible in any case. In addition, we do not set the
- -- flag for unconstrained floating-point type operations, since we want to
- -- allow for the generation of IEEE infinities in such cases.
+ -- Note that for discrete types, this call has no effect for MOD, REM, and
+ -- unary "+" for which overflow is never possible in any case.
+ --
+ -- 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);
pragma Inline (Activate_Range_Check);
begin
-- Return if no check needed
- if not Check_Float_Overflow
- or else not Is_Floating_Point_Type (Etype (N))
+ if 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
+ -- and do not expand the code for float overflow checking.
or else CodePeer_Mode
then
Typ : constant Entity_Id := Etype (N);
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
if Present (Case_Variable) then
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,
"variable """ &
Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
- """ is not typed",
+ """ is not a single string",
Variable_Location);
end if;
end if;
Parse_Choice_List
(In_Tree => In_Tree,
First_Choice => First_Choice,
- Flags => Flags);
+ Flags => Flags,
+ String_Type => Present (String_Type));
Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
Expect (Tok_Arrow, "`=>`");
End_Case_Construction
(Check_All_Labels => not When_Others and not Quiet_Output,
Case_Location => Location_Of (Case_Construction, In_Tree),
- Flags => Flags);
+ Flags => Flags,
+ String_Type => Present (String_Type));
Expect (Tok_End, "`END CASE`");
Remove_Next_End_Node;
procedure End_Case_Construction
(Check_All_Labels : Boolean;
Case_Location : Source_Ptr;
- Flags : Processing_Flags)
+ Flags : Processing_Flags;
+ String_Type : Boolean)
is
Non_Used : Natural := 0;
First_Non_Used : Choice_Node_Id := First_Choice_Node_Id;
-- of the string type have been used.
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
Non_Used := Non_Used + 1;
First_Non_Used := Choice;
end if;
end if;
- end loop;
+ end loop;
+
+ -- If only one is not used, report a single warning for this value
- -- 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 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.
- -- 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);
- elsif Non_Used > 1 then
+ 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, "?the following values are not used as labels:",
+ (Flags,
+ "?no when others for this case construction",
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;
end if;
procedure Parse_Choice_List
(In_Tree : Project_Node_Tree_Ref;
First_Choice : out Project_Node_Id;
- Flags : Processing_Flags)
+ Flags : Processing_Flags;
+ String_Type : Boolean := True)
is
Current_Choice : Project_Node_Id := Empty_Node;
Next_Choice : Project_Node_Id := Empty_Node;
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
- -- been already used.
+ if String_Type then
+ -- Check if the label is part of the string type and if it has not
+ -- been already used.
- Found := False;
- for Choice in Choice_First .. Choices.Last loop
- if Choices.Table (Choice).The_String = Choice_String then
+ Found := False;
+ for Choice in Choice_First .. Choices.Last loop
+ 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
- -- case construction so report an error.
+ -- But it has already appeared in a choice list for this
+ -- case construction so report an error.
- Error_Msg_Name_1 := Choice_String;
- Error_Msg (Flags, "duplicate case label %%", Token_Ptr);
+ Error_Msg_Name_1 := Choice_String;
+ Error_Msg (Flags, "duplicate case label %%", Token_Ptr);
- else
- Choices.Table (Choice).Already_Used := True;
- end if;
+ else
+ Choices.Table (Choice).Already_Used := True;
+ end if;
- exit;
- end if;
- end loop;
+ exit;
+ end if;
+ end loop;
- -- If the label is not part of the string list, report an error
+ -- 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);
+ 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
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure End_Case_Construction
(Check_All_Labels : Boolean;
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
-- case labels and to restore the previous state. In particular, in the
-- case of nested case constructions, the case labels of the enclosing case
procedure Parse_Choice_List
(In_Tree : Project_Node_Tree_Ref;
First_Choice : out Project_Node_Id;
- Flags : Processing_Flags);
+ Flags : Processing_Flags;
+ String_Type : Boolean := True);
-- Get the label for a choice list.
-- Report an error if
-- - a case label is not a literal string
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
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
with some projects, this might make the command line too long, and on
all systems often make it hard to read.
@end smallexample
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
@b{with} @b{external}("SETUP") & "path/prj.gpr"; --@i{ ILLEGAL}
@cindex @code{Project_Path}
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
@code{a.gpr} imports a project @code{b.gpr}, only @code{b.gpr} is searched in
@cindex @code{External}
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
themselves (so for instance you cannot use it to change the value
of your PATH as seen from the spawned compiler).
an attribute declaration.
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
@b{scenario variables}.
@c ---------------------------------------------
@noindent
-A @b{case} statement is used in a project file to effect conditional
-behavior. Through this statement, you can set the value of attributes
+A @b{case} construction is used in a project file to effect conditional
+behavior. Through this construction, you can set the value of attributes
and variables depending on the value previously assigned to a typed
variable.
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.
-The syntax of a @code{case} construction is based on the Ada case statement
-(although the @code{null} statement for empty alternatives is optional).
+The syntax of a @code{case} construction is based on the Ada case construction
+(although the @code{null} declaration for empty alternatives is optional).
-The case expression must be a typed string variable, whose value is often
-given by an external reference (@pxref{External Values}).
+The case expression must be a string variable, either typed or not, whose value
+is often given by an external reference (@pxref{External Values}).
Each alternative starts with the reserved word @code{when}, either a list of
literal strings separated by the @code{"|"} character or the reserved word
@code{others}, and the @code{"=>"} token.
-Each literal string must belong to the string type that is the type of the
-case variable.
-After each @code{=>}, there are zero or more statements. The only
-statements allowed in a case construction are other case constructions,
+When the case expression is a typed string variable, each literal string must
+belong to the string type that is the type of the case variable.
+After each @code{=>}, there are zero or more declarations. The only
+declarations allowed in a case construction are other case constructions,
attribute declarations and variable declarations. String type declarations and
package declarations are not allowed. Variable declarations are restricted to
variables that have already been declared before the case construction.
@smallexample
-case_statement ::=
- @i{case} @i{<typed_variable_>}name @i{is} @{case_item@} @i{end case} ;
+case_construction ::=
+ @i{case} @i{<variable_>}name @i{is} @{case_item@} @i{end case} ;
case_item ::=
@i{when} discrete_choice_list =>
- @{case_statement
+ @{case_declaration
| attribute_declaration
| variable_declaration
| empty_declaration@}
@end smallexample
@noindent
-Here is a typical example:
+Here is a typical example, with a typed string variable:
@smallexample @c projectfile
@group
procedure Check_Predicate_Use (T : Entity_Id) is
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)
and then Has_Predicates (T)
and then (not Has_Static_Predicate (T)
+ or else not Is_Static_Subtype (T)
or else Has_Dynamic_Predicate_Aspect (T))
then
Bad_Predicated_Subtype_Use
Insert_Before_And_Analyze (N, 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
-- class-wide wrapper is frozen. The body is only needed if expansion
-- is enabled.
projects / platform / upstream / linaro-gcc.git / commitdiff