diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 61ccf821d37..91804ed8a4e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,46 @@ +2014-08-04 Vincent Celier + + * 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 + + * sem_ch5.adb: Additional fix to Check_Predicate_Use. + +2014-08-04 Vincent Celier + + * projects.texi: Update documentation of case constructions with + variables that are not typed. + +2014-08-04 Ed Schonberg + + * 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 + + * 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 * prj-proc.adb, prj-part.adb, prj-strt.adb, prj.adb, prj.ads, diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 0b934eb2a2b..8072629666d 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -388,27 +388,46 @@ package body Checks is ----------------------------- 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. + -- 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). - 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; + if Present (Typ) and then Is_Floating_Point_Type (Typ) then + + -- 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; - -- Nothing to do for Rem/Mod/Plus (overflow not possible) - - if Nkind_In (N, N_Op_Rem, N_Op_Mod, N_Op_Plus) then - return; - 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); diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 9362550b382..2dca67e1c4a 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -145,10 +145,19 @@ package Checks is -- 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); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 5532d58bf2d..9467154cfda 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1641,10 +1641,11 @@ package body Exp_Util is 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 @@ -1663,9 +1664,12 @@ package body Exp_Util is 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 diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 9053cfca54f..672c45419a9 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -827,11 +827,11 @@ package body Prj.Dect is 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; @@ -914,7 +914,8 @@ package body Prj.Dect is 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, "`=>`"); @@ -941,7 +942,8 @@ package body Prj.Dect is 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; diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb index c79c199cedb..1224270f1f4 100644 --- a/gcc/ada/prj-strt.adb +++ b/gcc/ada/prj-strt.adb @@ -297,7 +297,8 @@ package body Prj.Strt is 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; @@ -306,7 +307,8 @@ package body Prj.Strt is -- 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; @@ -314,27 +316,35 @@ package body Prj.Strt is First_Non_Used := Choice; 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; + + -- 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; @@ -487,7 +497,8 @@ package body Prj.Strt is 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; @@ -517,38 +528,40 @@ package body Prj.Strt is 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; + else + Choices.Table (Choice).Already_Used := True; + end if; + + exit; 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 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; -- Scan past the label diff --git a/gcc/ada/prj-strt.ads b/gcc/ada/prj-strt.ads index 7dbe5302781..66a96d3e6f7 100644 --- a/gcc/ada/prj-strt.ads +++ b/gcc/ada/prj-strt.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -59,7 +59,8 @@ private package Prj.Strt is 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 @@ -70,7 +71,8 @@ private package Prj.Strt is 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 diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index b61decaa7ef..06e3ac6796b 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -2403,7 +2403,7 @@ The environment variables at the time you launch @command{gprbuild} 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. @@ -2427,7 +2427,7 @@ building. The syntax looks like @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} @@ -2566,7 +2566,7 @@ Here are a few valid examples: @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 @@ -2637,7 +2637,7 @@ Example: @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). @@ -3403,7 +3403,7 @@ list expression, and can therefore appear in a variable declaration or 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}. @@ -3565,8 +3565,8 @@ A @b{context} may be one of the following: @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. @@ -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. 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{}name @i{is} @{case_item@} @i{end case} ; +case_construction ::= + @i{case} @i{}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@} @@ -3606,7 +3606,7 @@ discrete_choice_list ::= string_literal @{| string_literal@} | @i{others} @end smallexample @noindent -Here is a typical example: +Here is a typical example, with a typed string variable: @smallexample @c projectfile @group diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 37b62d18a1b..65a000f6da8 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2204,9 +2204,15 @@ package body Sem_Ch5 is 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 diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 251fc43f751..0521efb9033 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -2321,6 +2321,13 @@ package body Sem_Ch8 is 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.