diff options
Diffstat (limited to 'gcc/ada/sem_ch5.adb')
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 266 |
1 files changed, 81 insertions, 185 deletions
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 2342c54..336507a 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2020, 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- -- @@ -26,6 +26,7 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Expander; use Expander; @@ -39,8 +40,6 @@ with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; -with Restrict; use Restrict; -with Rident; use Rident; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Case; use Sem_Case; @@ -306,9 +305,8 @@ package body Sem_Ch5 is if Is_Entity_Name (Opnd) and then (Ekind (Entity (Opnd)) = E_Out_Parameter - or else Ekind_In (Entity (Opnd), - E_In_Out_Parameter, - E_Generic_In_Out_Parameter) + or else Ekind (Entity (Opnd)) in + E_In_Out_Parameter | E_Generic_In_Out_Parameter or else (Ekind (Entity (Opnd)) = E_Variable and then Nkind (Parent (Entity (Opnd))) = @@ -321,7 +319,7 @@ package body Sem_Ch5 is -- If assignment operand is a component reference, then we get the -- actual subtype of the component for the unconstrained case. - elsif Nkind_In (Opnd, N_Selected_Component, N_Explicit_Dereference) + elsif Nkind (Opnd) in N_Selected_Component | N_Explicit_Dereference and then not Is_Unchecked_Union (Opnd_Type) then Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd); @@ -823,12 +821,10 @@ package body Sem_Ch5 is -- that of the target mutable object. if Is_Entity_Name (Lhs) - and then Ekind_In (Entity (Lhs), E_In_Out_Parameter, - E_Out_Parameter, - E_Variable) + and then Is_Assignable (Entity (Lhs)) and then Is_Composite_Type (T1) and then not Is_Constrained (Etype (Entity (Lhs))) - and then Nkind_In (Rhs, N_If_Expression, N_Case_Expression) + and then Nkind (Rhs) in N_If_Expression | N_Case_Expression then Resolve (Rhs, Base_Type (T1)); @@ -997,7 +993,7 @@ package body Sem_Ch5 is and then (Nkind (Rhs) /= N_Function_Call or else Nkind (N) /= N_Block_Statement) then - -- Assignment verifies that the length of the Lsh and Rhs are equal, + -- Assignment verifies that the length of the Lhs and Rhs are equal, -- but of course the indexes do not have to match. If the right-hand -- side is a type conversion to an unconstrained type, a length check -- is performed on the expression itself during expansion. In rare @@ -1005,7 +1001,7 @@ package body Sem_Ch5 is -- with a different representation, triggering incorrect code in the -- back end. - Apply_Length_Check (Rhs, Etype (Lhs)); + Apply_Length_Check_On_Assignment (Rhs, Etype (Lhs), Lhs); else -- Discriminant checks are applied in the course of expansion @@ -1242,7 +1238,7 @@ package body Sem_Ch5 is -- Do not install the return object - if not Ekind_In (Id, E_Constant, E_Variable) + if Ekind (Id) not in E_Constant | E_Variable or else not Is_Return_Object (Id) then Install_Entity (Id); @@ -1263,13 +1259,6 @@ package body Sem_Ch5 is -- Start of processing for Analyze_Block_Statement begin - -- In SPARK mode, we reject block statements. Note that the case of - -- block statements generated by the expander is fine. - - if Nkind (Original_Node (N)) = N_Block_Statement then - Check_SPARK_05_Restriction ("block statement is not allowed", N); - end if; - -- If no handled statement sequence is present, things are really messed -- up, and we just return immediately (defence against previous errors). @@ -1483,9 +1472,7 @@ package body Sem_Ch5 is if Is_Entity_Name (Exp) then Ent := Entity (Exp); - if Ekind_In (Ent, E_Variable, - E_In_Out_Parameter, - E_Out_Parameter) + if Ekind (Ent) in E_Variable | E_In_Out_Parameter | E_Out_Parameter then if List_Length (Choices) = 1 and then Nkind (First (Choices)) in N_Subexpr @@ -1583,13 +1570,6 @@ package body Sem_Ch5 is Analyze_Choices (Alternatives (N), Exp_Type); Check_Choices (N, Alternatives (N), Exp_Type, Others_Present); - -- Case statement with single OTHERS alternative not allowed in SPARK - - if Others_Present and then List_Length (Alternatives (N)) = 1 then - Check_SPARK_05_Restriction - ("OTHERS as unique case alternative is not allowed", N); - end if; - if Exp_Type = Universal_Integer and then not Others_Present then Error_Msg_N ("case on universal integer requires OTHERS choice", Exp); end if; @@ -1672,11 +1652,6 @@ package body Sem_Ch5 is return; else - if Has_Loop_In_Inner_Open_Scopes (U_Name) then - Check_SPARK_05_Restriction - ("exit label must name the closest enclosing loop", N); - end if; - Set_Has_Exit (U_Name); end if; @@ -1712,42 +1687,6 @@ package body Sem_Ch5 is Check_Unset_Reference (Cond); end if; - -- In SPARK mode, verify that the exit statement respects the SPARK - -- restrictions. - - if Present (Cond) then - if Nkind (Parent (N)) /= N_Loop_Statement then - Check_SPARK_05_Restriction - ("exit with when clause must be directly in loop", N); - end if; - - else - if Nkind (Parent (N)) /= N_If_Statement then - if Nkind (Parent (N)) = N_Elsif_Part then - Check_SPARK_05_Restriction - ("exit must be in IF without ELSIF", N); - else - Check_SPARK_05_Restriction ("exit must be directly in IF", N); - end if; - - elsif Nkind (Parent (Parent (N))) /= N_Loop_Statement then - Check_SPARK_05_Restriction - ("exit must be in IF directly in loop", N); - - -- First test the presence of ELSE, so that an exit in an ELSE leads - -- to an error mentioning the ELSE. - - elsif Present (Else_Statements (Parent (N))) then - Check_SPARK_05_Restriction ("exit must be in IF without ELSE", N); - - -- An exit in an ELSIF does not reach here, as it would have been - -- detected in the case (Nkind (Parent (N)) /= N_If_Statement). - - elsif Present (Elsif_Parts (Parent (N))) then - Check_SPARK_05_Restriction ("exit must be in IF without ELSIF", N); - end if; - end if; - -- Chain exit statement to associated loop entity Set_Next_Exit_Statement (N, First_Exit_Statement (Scope_Id)); @@ -1772,8 +1711,6 @@ package body Sem_Ch5 is Label_Ent : Entity_Id; begin - Check_SPARK_05_Restriction ("goto statement is not allowed", N); - -- Actual semantic checks Check_Unreachable_Code (N); @@ -1812,7 +1749,8 @@ package body Sem_Ch5 is Scope_Id := Scope_Stack.Table (J).Entity; if Label_Scope = Scope_Id - or else not Ekind_In (Scope_Id, E_Block, E_Loop, E_Return_Statement) + or else Ekind (Scope_Id) not in + E_Block | E_Loop | E_Return_Statement then if Scope_Id /= Label_Scope then Error_Msg_N @@ -1847,7 +1785,7 @@ package body Sem_Ch5 is Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; -- Recursively save value of this global, will be restored on exit - Save_In_Deleted_Code : Boolean; + Save_In_Deleted_Code : Boolean := In_Deleted_Code; Del : Boolean := False; -- This flag gets set True if a True condition has been found, which @@ -1893,7 +1831,7 @@ package body Sem_Ch5 is -- If condition is False, analyze THEN with expansion off - else -- Is_False (Expr_Value (Cond)) + else pragma Assert (Is_False (Expr_Value (Cond))); Expander_Mode_Save_And_Set (False); In_Deleted_Code := True; Analyze_Statements (Tstm); @@ -2273,8 +2211,8 @@ package body Sem_Ch5 is -- If the domain of iteration is an expression, create a declaration for -- it, so that finalization actions are introduced outside of the loop. - -- The declaration must be a renaming because the body of the loop may - -- assign to elements. + -- The declaration must be a renaming (both in GNAT and GNATprove + -- modes), because the body of the loop may assign to elements. if not Is_Entity_Name (Iter_Name) @@ -2283,14 +2221,15 @@ package body Sem_Ch5 is -- doing expansion. and then (Nkind (Parent (N)) /= N_Quantified_Expression - or else Operating_Mode = Check_Semantics) + or else (Operating_Mode = Check_Semantics + and then not GNATprove_Mode)) - -- Do not perform this expansion for ASIS and when expansion is - -- disabled, where the temporary may hide the transformation of a - -- selected component into a prefixed function call, and references - -- need to see the original expression. + -- Do not perform this expansion when expansion is disabled, where the + -- temporary may hide the transformation of a selected component into + -- a prefixed function call, and references need to see the original + -- expression. - and then Expander_Active + and then (Expander_Active or GNATprove_Mode) then declare Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name); @@ -2300,7 +2239,7 @@ package body Sem_Ch5 is begin -- If the domain of iteration is an array component that depends - -- on a discriminant, create actual subtype for it. preanalysis + -- on a discriminant, create actual subtype for it. Preanalysis -- does not generate the actual subtype of a selected component. if Nkind (Iter_Name) = N_Selected_Component @@ -2378,6 +2317,7 @@ package body Sem_Ch5 is Insert_Actions (Parent (Parent (N)), New_List (Decl)); Rewrite (Name (N), New_Occurrence_Of (Id, Loc)); + Analyze (Name (N)); Set_Etype (Id, Typ); Set_Etype (Name (N), Typ); end; @@ -2449,7 +2389,7 @@ package body Sem_Ch5 is -- AI12-0047 stipulates that the domain (array or container) -- cannot be a component that depends on a discriminant if the -- enclosing object is mutable, to prevent a modification of the - -- dowmain of iteration in the course of an iteration. + -- domain of iteration in the course of an iteration. -- If the object is an expression it has been captured in a -- temporary, so examine original node. @@ -2515,7 +2455,7 @@ package body Sem_Ch5 is Check_Subtype_Indication (Etype (Def_Id)); - -- For a predefined container, The type of the loop variable is + -- For a predefined container, the type of the loop variable is -- the Iterator_Element aspect of the container type. else @@ -2580,10 +2520,9 @@ package body Sem_Ch5 is if Nkind (Orig_Iter_Name) = N_Selected_Component and then Present (Entity (Selector_Name (Orig_Iter_Name))) - and then Ekind_In - (Entity (Selector_Name (Orig_Iter_Name)), - E_Component, - E_Discriminant) + and then + Ekind (Entity (Selector_Name (Orig_Iter_Name))) in + E_Component | E_Discriminant and then Is_Dependent_Component_Of_Mutable_Object (Orig_Iter_Name) then @@ -2686,6 +2625,10 @@ package body Sem_Ch5 is end if; end if; + + if Present (Iterator_Filter (N)) then + Analyze_And_Resolve (Iterator_Filter (N), Standard_Boolean); + end if; end Analyze_Iterator_Specification; ------------------- @@ -2857,8 +2800,8 @@ package body Sem_Ch5 is if Analyzed (Original_Bound) then return Original_Bound; - elsif Nkind_In (Analyzed_Bound, N_Integer_Literal, - N_Character_Literal) + elsif Nkind (Analyzed_Bound) in + N_Integer_Literal | N_Character_Literal or else Is_Entity_Name (Analyzed_Bound) then Analyze_And_Resolve (Original_Bound, Typ); @@ -3015,13 +2958,6 @@ package body Sem_Ch5 is end if; end; - -- Loop parameter specification must include subtype mark in SPARK - - if Nkind (DS) = N_Range then - Check_SPARK_05_Restriction - ("loop parameter specification must include subtype mark", N); - end if; - -- Analyze the subtype definition and create temporaries for the bounds. -- Do not evaluate the range when preanalyzing a quantified expression -- because bounds expressed as function calls with side effects will be @@ -3063,8 +2999,8 @@ package body Sem_Ch5 is and then not Is_Type (Entity (DS_Copy))) or else (Nkind (DS_Copy) = N_Attribute_Reference - and then Nam_In (Attribute_Name (DS_Copy), - Name_Loop_Entry, Name_Old)) + and then Attribute_Name (DS_Copy) in + Name_Loop_Entry | Name_Old) or else Has_Aspect (Etype (DS_Copy), Aspect_Iterable) @@ -3160,7 +3096,7 @@ package body Sem_Ch5 is Check_Predicate_Use (Entity (Subtype_Mark (DS))); end if; - Make_Index (DS, N, In_Iter_Schm => True); + Make_Index (DS, N); Set_Ekind (Id, E_Loop_Parameter); -- A quantified expression which appears in a pre- or post-condition may @@ -3204,14 +3140,15 @@ package body Sem_Ch5 is -- Case where we have a range or a subtype, get type bounds - if Nkind_In (DS, N_Range, N_Subtype_Indication) + if Nkind (DS) in N_Range | N_Subtype_Indication and then not Error_Posted (DS) and then Etype (DS) /= Any_Type and then Is_Discrete_Type (Etype (DS)) then declare - L : Node_Id; - H : Node_Id; + L : Node_Id; + H : Node_Id; + Null_Range : Boolean := False; begin if Nkind (DS) = N_Range then @@ -3231,6 +3168,14 @@ package body Sem_Ch5 is -- null range may be detected statically. if Compile_Time_Compare (L, H, Assume_Valid => True) = GT then + if Compile_Time_Compare (L, H, Assume_Valid => False) = GT then + -- Since we know the range of the loop is always null, + -- set the appropriate flag to remove the loop entirely + -- during expansion. + + Set_Is_Null_Loop (Loop_Nod); + Null_Range := True; + end if; -- Suppress the warning if inside a generic template or -- instance, since in practice they tend to be dubious in these @@ -3241,24 +3186,14 @@ package body Sem_Ch5 is -- Specialize msg if invalid values could make the loop -- non-null after all. - if Compile_Time_Compare - (L, H, Assume_Valid => False) = GT - then - -- Since we know the range of the loop is null, set the - -- appropriate flag to remove the loop entirely during - -- expansion. - - Set_Is_Null_Loop (Loop_Nod); - + if Null_Range then if Comes_From_Source (N) then Error_Msg_N ("??loop range is null, loop will not execute", DS); end if; - -- Here is where the loop could execute because of - -- invalid values, so issue appropriate message and in - -- this case we do not set the Is_Null_Loop flag since - -- the loop may execute. + -- Here is where the loop could execute because of + -- invalid values, so issue appropriate message. elsif Comes_From_Source (N) then Error_Msg_N @@ -3367,10 +3302,20 @@ package body Sem_Ch5 is -- the warning is perfectly acceptable. exception - when others => null; + when others => + -- With debug flag K we will get an exception unless an error + -- has already occurred (useful for debugging). + + if Debug_Flag_K then + Check_Error_Detected; + end if; end; end if; + if Present (Iterator_Filter (N)) then + Analyze_And_Resolve (Iterator_Filter (N), Standard_Boolean); + end if; + -- A loop parameter cannot be effectively volatile (SPARK RM 7.1.3(4)). -- This check is relevant only when SPARK_Mode is on as it is not a -- standard Ada legality check. @@ -3389,13 +3334,6 @@ package body Sem_Ch5 is -- The following exception is raised by routine Prepare_Loop_Statement -- to avoid further analysis of a transformed loop. - function Disable_Constant (N : Node_Id) return Traverse_Result; - -- If N represents an E_Variable entity, set Is_True_Constant To False - - procedure Disable_Constants is new Traverse_Proc (Disable_Constant); - -- Helper for Analyze_Loop_Statement, to unset Is_True_Constant on - -- variables referenced within an OpenACC construct. - procedure Prepare_Loop_Statement (Iter : Node_Id; Stop_Processing : out Boolean); @@ -3403,22 +3341,6 @@ package body Sem_Ch5 is -- transformed prior to analysis, and if so, perform it. -- If Stop_Processing is set to True, should stop further processing. - ---------------------- - -- Disable_Constant -- - ---------------------- - - function Disable_Constant (N : Node_Id) return Traverse_Result is - begin - if Is_Entity_Name (N) - and then Present (Entity (N)) - and then Ekind (Entity (N)) = E_Variable - then - Set_Is_True_Constant (Entity (N), False); - end if; - - return OK; - end Disable_Constant; - ---------------------------- -- Prepare_Loop_Statement -- ---------------------------- @@ -3975,7 +3897,7 @@ package body Sem_Ch5 is Enter_Name (Id); end if; - -- In an element iterator, The loop parameter is a variable if + -- In an element iterator, the loop parameter is a variable if -- the domain of iteration (container or array) is a variable. if not Of_Present (I_Spec) @@ -3994,6 +3916,12 @@ package body Sem_Ch5 is Analyze_Statements (Statements (N)); end if; + -- If the loop has no side effects, mark it for removal. + + if Side_Effect_Free_Loop (N) then + Set_Is_Null_Loop (N); + end if; + -- When the iteration scheme of a loop contains attribute 'Loop_Entry, -- the loop is transformed into a conditional block. Retrieve the loop. @@ -4030,15 +3958,6 @@ package body Sem_Ch5 is if No (Iter) and then not Has_Exit (Ent) then Check_Unreachable_Code (Stmt); end if; - - -- Variables referenced within a loop subject to possible OpenACC - -- offloading may be implicitly written to as part of the OpenACC - -- transaction. Clear flags possibly conveying that they are constant, - -- set for example when the code does not explicitly assign them. - - if Is_OpenAcc_Environment (Stmt) then - Disable_Constants (Stmt); - end if; end Analyze_Loop_Statement; ---------------------------- @@ -4166,12 +4085,9 @@ package body Sem_Ch5 is end loop; -- If a label follows us, then we never have dead code, since - -- someone could branch to the label, so we just ignore it, unless - -- we are in formal mode where goto statements are not allowed. + -- someone could branch to the label, so we just ignore it. - if Nkind (Nxt) = N_Label - and then not Restriction_Check_Required (SPARK_05) - then + if Nkind (Nxt) = N_Label then return; -- Otherwise see if we have a real statement following us @@ -4204,8 +4120,8 @@ package body Sem_Ch5 is -- This is the one case where we remove dead code in the -- semantics as opposed to the expander, and we do not want -- to remove code if we are not in code generation mode, - -- since this messes up the ASIS trees or loses useful - -- information in the CodePeer tree. + -- since this messes up the tree or loses useful information + -- for CodePeer. -- Note that one might react by moving the whole circuit to -- exp_ch5, but then we lose the warning in -gnatc mode. @@ -4230,15 +4146,8 @@ package body Sem_Ch5 is end loop; end if; - -- Now issue the warning (or error in formal mode) - - if Restriction_Check_Required (SPARK_05) then - Check_SPARK_05_Restriction - ("unreachable code is not allowed", Error_Node); - else - Error_Msg - ("??unreachable code!", Sloc (Error_Node), Error_Node); - end if; + Error_Msg + ("??unreachable code!", Sloc (Error_Node), Error_Node); end if; -- If the unconditional transfer of control instruction is the @@ -4478,21 +4387,8 @@ package body Sem_Ch5 is -- visible in the loop. elsif Has_Implicit_Dereference (Etype (R_Copy)) then - declare - Disc : Entity_Id; - - begin - Disc := First_Discriminant (Typ); - while Present (Disc) loop - if Has_Implicit_Dereference (Disc) then - Build_Explicit_Dereference (R_Copy, Disc); - exit; - end if; - - Next_Discriminant (Disc); - end loop; - end; - + Build_Explicit_Dereference + (R_Copy, Get_Reference_Discriminant (Etype (R_Copy))); end if; end if; |