X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_ch5.adb;h=d95634f27efb20f1c6a0e7b4a6f772280b64644c;hb=2d705783b7d53f942c471703b131ed75f0edbe0c;hp=2a4cf9d7ef8c729c52c8540584386e32b54d21d9;hpb=e8a502abe49001ae87b658156f9a0fb8c1f60776;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 2a4cf9d7ef8..d95634f27ef 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -16,8 +16,8 @@ -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -26,25 +26,30 @@ with Atree; use Atree; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Expander; use Expander; with Exp_Util; use Exp_Util; with Freeze; use Freeze; +with Lib; use Lib; with Lib.Xref; use Lib.Xref; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; +with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Case; use Sem_Case; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; +with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; +with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; with Targparm; use Targparm; @@ -56,8 +61,8 @@ package body Sem_Ch5 is Unblocked_Exit_Count : Nat := 0; -- This variable is used when processing if statements, case statements, -- and block statements. It counts the number of exit points that are - -- not blocked by unconditional transfer instructions (for IF and CASE, - -- these are the branches of the conditional, for a block, they are the + -- not blocked by unconditional transfer instructions: for IF and CASE, + -- these are the branches of the conditional; for a block, they are the -- statement sequence of the block, and the statement sequences of any -- exception handlers that are part of the block. When processing is -- complete, if this count is zero, it means that control cannot fall @@ -71,15 +76,6 @@ package body Sem_Ch5 is procedure Analyze_Iteration_Scheme (N : Node_Id); - procedure Check_Possible_Current_Value_Condition (Cnode : Node_Id); - -- Cnode is N_If_Statement, N_Elsif_Part, or N_Iteration_Scheme - -- (the latter when a WHILE condition is present). This call checks - -- if Condition (Cnode) is of the form ([NOT] var op val), where var - -- is a simple object, val is known at compile time, and op is one - -- of the six relational operators. If this is the case, and the - -- Current_Value field of "var" is not set, then it is set to Cnode. - -- See Exp_Util.Set_Current_Value_Condition for further details. - ------------------------ -- Analyze_Assignment -- ------------------------ @@ -90,12 +86,17 @@ package body Sem_Ch5 is T1 : Entity_Id; T2 : Entity_Id; Decl : Node_Id; - Ent : Entity_Id; procedure Diagnose_Non_Variable_Lhs (N : Node_Id); -- N is the node for the left hand side of an assignment, and it -- is not a variable. This routine issues an appropriate diagnostic. + procedure Kill_Lhs; + -- This is called to kill current value settings of a simple variable + -- on the left hand side. We call it if we find any error in analyzing + -- the assignment, and at the end of processing before setting any new + -- current values in place. + procedure Set_Assignment_Type (Opnd : Node_Id; Opnd_Type : in out Entity_Id); @@ -168,6 +169,23 @@ package body Sem_Ch5 is end if; end Diagnose_Non_Variable_Lhs; + -------------- + -- Kill_LHS -- + -------------- + + procedure Kill_Lhs is + begin + if Is_Entity_Name (Lhs) then + declare + Ent : constant Entity_Id := Entity (Lhs); + begin + if Present (Ent) then + Kill_Current_Values (Ent); + end if; + end; + end if; + end Kill_Lhs; + ------------------------- -- Set_Assignment_Type -- ------------------------- @@ -234,6 +252,9 @@ package body Sem_Ch5 is begin Analyze (Rhs); Analyze (Lhs); + + -- Start type analysis for assignment + T1 := Etype (Lhs); -- In the most general case, both Lhs and Rhs can be overloaded, and we @@ -314,6 +335,7 @@ package body Sem_Ch5 is if T1 = Any_Type then Error_Msg_N ("no valid types for left-hand side for assignment", Lhs); + Kill_Lhs; return; end if; end if; @@ -321,6 +343,74 @@ package body Sem_Ch5 is Resolve (Lhs, T1); if not Is_Variable (Lhs) then + + -- Ada 2005 (AI-327): Check assignment to the attribute Priority of + -- a protected object. + + declare + Ent : Entity_Id; + S : Entity_Id; + + begin + if Ada_Version >= Ada_05 then + + -- Handle chains of renamings + + Ent := Lhs; + while Nkind (Ent) in N_Has_Entity + and then Present (Entity (Ent)) + and then Present (Renamed_Object (Entity (Ent))) + loop + Ent := Renamed_Object (Entity (Ent)); + end loop; + + if (Nkind (Ent) = N_Attribute_Reference + and then Attribute_Name (Ent) = Name_Priority) + + -- Renamings of the attribute Priority applied to protected + -- objects have been previously expanded into calls to the + -- Get_Ceiling run-time subprogram. + + or else + (Nkind (Ent) = N_Function_Call + and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling) + or else + Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling))) + then + -- The enclosing subprogram cannot be a protected function + + S := Current_Scope; + while not (Is_Subprogram (S) + and then Convention (S) = Convention_Protected) + and then S /= Standard_Standard + loop + S := Scope (S); + end loop; + + if Ekind (S) = E_Function + and then Convention (S) = Convention_Protected + then + Error_Msg_N + ("protected function cannot modify protected object", + Lhs); + end if; + + -- Changes of the ceiling priority of the protected object + -- are only effective if the Ceiling_Locking policy is in + -- effect (AARM D.5.2 (5/2)). + + if Locking_Policy /= 'C' then + Error_Msg_N ("assignment to the attribute PRIORITY has " & + "no effect?", Lhs); + Error_Msg_N ("\since no Locking_Policy has been " & + "specified", Lhs); + end if; + + return; + end if; + end if; + end; + Diagnose_Non_Variable_Lhs (Lhs); return; @@ -339,6 +429,30 @@ package body Sem_Ch5 is -- to avoid scoping issues in the back-end. T1 := Etype (Lhs); + + -- Ada 2005 (AI-50217, AI-326): Check wrong dereference of incomplete + -- type. For example: + + -- limited with P; + -- package Pkg is + -- type Acc is access P.T; + -- end Pkg; + + -- with Pkg; use Acc; + -- procedure Example is + -- A, B : Acc; + -- begin + -- A.all := B.all; -- ERROR + -- end Example; + + if Nkind (Lhs) = N_Explicit_Dereference + and then Ekind (T1) = E_Incomplete_Type + then + Error_Msg_N ("invalid use of incomplete type", Lhs); + Kill_Lhs; + return; + end if; + Set_Assignment_Type (Lhs, T1); Resolve (Rhs, T1); @@ -347,18 +461,29 @@ package body Sem_Ch5 is -- Remaining steps are skipped if Rhs was syntactically in error if Rhs = Error then + Kill_Lhs; return; end if; T2 := Etype (Rhs); - if Covers (T1, T2) then - null; - else + if not Covers (T1, T2) then Wrong_Type (Rhs, Etype (Lhs)); + Kill_Lhs; return; end if; + -- Ada 2005 (AI-326): In case of explicit dereference of incomplete + -- types, use the non-limited view if available + + if Nkind (Rhs) = N_Explicit_Dereference + and then Ekind (T2) = E_Incomplete_Type + and then Is_Tagged_Type (T2) + and then Present (Non_Limited_View (T2)) + then + T2 := Non_Limited_View (T2); + end if; + Set_Assignment_Type (Rhs, T2); if Total_Errors_Detected /= 0 then @@ -372,6 +497,7 @@ package body Sem_Ch5 is end if; if T1 = Any_Type or else T2 = Any_Type then + Kill_Lhs; return; end if; @@ -388,39 +514,78 @@ package body Sem_Ch5 is Error_Msg_N ("dynamically tagged expression required!", Rhs); end if; - -- Tag propagation is done only in semantics mode only. If expansion - -- is on, the rhs tag indeterminate function call has been expanded - -- and tag propagation would have happened too late, so the - -- propagation take place in expand_call instead. + -- Propagate the tag from a class-wide target to the rhs when the rhs + -- is a tag-indeterminate call. - if not Expander_Active - and then Is_Class_Wide_Type (T1) - and then Is_Tag_Indeterminate (Rhs) + if Is_Tag_Indeterminate (Rhs) then + if Is_Class_Wide_Type (T1) then + Propagate_Tag (Lhs, Rhs); + + elsif Nkind (Rhs) = N_Function_Call + and then Is_Entity_Name (Name (Rhs)) + and then Is_Abstract_Subprogram (Entity (Name (Rhs))) + then + Error_Msg_N + ("call to abstract function must be dispatching", Name (Rhs)); + + elsif Nkind (Rhs) = N_Qualified_Expression + and then Nkind (Expression (Rhs)) = N_Function_Call + and then Is_Entity_Name (Name (Expression (Rhs))) + and then + Is_Abstract_Subprogram (Entity (Name (Expression (Rhs)))) + then + Error_Msg_N + ("call to abstract function must be dispatching", + Name (Expression (Rhs))); + end if; + end if; + + -- Ada 2005 (AI-230 and AI-385): When the lhs type is an anonymous + -- access type, apply an implicit conversion of the rhs to that type + -- to force appropriate static and run-time accessibility checks. + + if Ada_Version >= Ada_05 + and then Ekind (T1) = E_Anonymous_Access_Type then - Propagate_Tag (Lhs, Rhs); + Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); + Analyze_And_Resolve (Rhs, T1); end if; -- Ada 2005 (AI-231) if Ada_Version >= Ada_05 - and then Nkind (Rhs) = N_Null - and then Is_Access_Type (T1) + and then Can_Never_Be_Null (T1) and then not Assignment_OK (Lhs) - and then ((Is_Entity_Name (Lhs) - and then Can_Never_Be_Null (Entity (Lhs))) - or else Can_Never_Be_Null (Etype (Lhs))) then - Error_Msg_N - ("(Ada 2005) NULL not allowed in null-excluding objects", Lhs); + if Nkind (Rhs) = N_Null then + Apply_Compile_Time_Constraint_Error + (N => Rhs, + Msg => "(Ada 2005) NULL not allowed in null-excluding objects?", + Reason => CE_Null_Not_Allowed); + return; + + elsif not Can_Never_Be_Null (T2) then + Rewrite (Rhs, + Convert_To (T1, Relocate_Node (Rhs))); + Analyze_And_Resolve (Rhs, T1); + end if; end if; if Is_Scalar_Type (T1) then Apply_Scalar_Range_Check (Rhs, Etype (Lhs)); + -- For array types, verify that lengths match. If the right hand side + -- if a function call that has been inlined, the assignment has been + -- rewritten as a block, and the constraint check will be applied to the + -- assignment within the block. + elsif Is_Array_Type (T1) and then (Nkind (Rhs) /= N_Type_Conversion - or else Is_Constrained (Etype (Rhs))) + or else Is_Constrained (Etype (Rhs))) + 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, -- but of course the indices do not have to match. If the right-hand @@ -445,7 +610,7 @@ package body Sem_Ch5 is -- ??? a real accessibility check is needed when ??? - -- Post warning for useless assignment + -- Post warning for redundant assignment or variable to itself if Warn_On_Redundant_Constructs @@ -480,33 +645,81 @@ package body Sem_Ch5 is Error_Msg_CRT ("composite assignment", N); end if; - -- One more step. Let's see if we have a simple assignment of a - -- known at compile time value to a simple variable. If so, we - -- can record the value as the current value providing that: + -- Check elaboration warning for left side if not in elab code - -- We still have a simple assignment statement (no expansion - -- activity has modified it in some peculiar manner) + if not In_Subprogram_Or_Concurrent_Unit then + Check_Elab_Assign (Lhs); + end if; - -- The type is a discrete type + -- Final step. If left side is an entity, then we may be able to + -- reset the current tracked values to new safe values. We only have + -- something to do if the left side is an entity name, and expansion + -- has not modified the node into something other than an assignment, + -- and of course we only capture values if it is safe to do so. - -- The assignment is to a named entity + if Is_Entity_Name (Lhs) + and then Nkind (N) = N_Assignment_Statement + then + declare + Ent : constant Entity_Id := Entity (Lhs); - -- The value is known at compile time + begin + if Safe_To_Capture_Value (N, Ent) then + + -- If simple variable on left side, warn if this assignment + -- blots out another one (rendering it useless) and note + -- location of assignment in case no one references value. + -- We only do this for source assignments, otherwise we can + -- generate bogus warnings when an assignment is rewritten as + -- another assignment, and gets tied up with itself. + + if Warn_On_Modified_Unread + and then Ekind (Ent) = E_Variable + and then Comes_From_Source (N) + and then In_Extended_Main_Source_Unit (Ent) + then + Warn_On_Useless_Assignment (Ent, Sloc (N)); + Set_Last_Assignment (Ent, Lhs); + end if; - if Nkind (N) /= N_Assignment_Statement - or else not Is_Discrete_Type (T1) - or else not Is_Entity_Name (Lhs) - or else not Compile_Time_Known_Value (Rhs) - then - return; - end if; + -- If we are assigning an access type and the left side is an + -- entity, then make sure that the Is_Known_[Non_]Null flags + -- properly reflect the state of the entity after assignment. + + if Is_Access_Type (T1) then + if Known_Non_Null (Rhs) then + Set_Is_Known_Non_Null (Ent, True); + + elsif Known_Null (Rhs) + and then not Can_Never_Be_Null (Ent) + then + Set_Is_Known_Null (Ent, True); + + else + Set_Is_Known_Null (Ent, False); + + if not Can_Never_Be_Null (Ent) then + Set_Is_Known_Non_Null (Ent, False); + end if; + end if; - Ent := Entity (Lhs); + -- For discrete types, we may be able to set the current value + -- if the value is known at compile time. - -- Capture value if save to do so + elsif Is_Discrete_Type (T1) + and then Compile_Time_Known_Value (Rhs) + then + Set_Current_Value (Ent, Rhs); + else + Set_Current_Value (Ent, Empty); + end if; - if Safe_To_Capture_Value (N, Ent) then - Set_Current_Value (Ent, Rhs); + -- If not safe to capture values, kill them + + else + Kill_Lhs; + end if; + end; end if; end Analyze_Assignment; @@ -613,6 +826,7 @@ package body Sem_Ch5 is end if; Check_References (Ent); + Warn_On_Useless_Assignments (Ent); End_Scope; if Unblocked_Exit_Count = 0 then @@ -739,9 +953,30 @@ package body Sem_Ch5 is begin Unblocked_Exit_Count := 0; Exp := Expression (N); - Analyze_And_Resolve (Exp, Any_Discrete); + Analyze (Exp); + + -- The expression must be of any discrete type. In rare cases, the + -- expander constructs a case statement whose expression has a private + -- type whose full view is discrete. This can happen when generating + -- a stream operation for a variant type after the type is frozen, + -- when the partial of view of the type of the discriminant is private. + -- In that case, use the full view to analyze case alternatives. + + if not Is_Overloaded (Exp) + and then not Comes_From_Source (N) + and then Is_Private_Type (Etype (Exp)) + and then Present (Full_View (Etype (Exp))) + and then Is_Discrete_Type (Full_View (Etype (Exp))) + then + Resolve (Exp, Etype (Exp)); + Exp_Type := Full_View (Etype (Exp)); + + else + Analyze_And_Resolve (Exp, Any_Discrete); + Exp_Type := Etype (Exp); + end if; + Check_Unset_Reference (Exp); - Exp_Type := Etype (Exp); Exp_Btype := Base_Type (Exp_Type); -- The expression must be of a discrete type which must be determinable @@ -870,7 +1105,10 @@ package body Sem_Ch5 is Set_Has_Exit (Scope_Id); exit; - elsif Kind = E_Block or else Kind = E_Loop then + elsif Kind = E_Block + or else Kind = E_Loop + or else Kind = E_Return_Statement + then null; else @@ -896,32 +1134,46 @@ package body Sem_Ch5 is Label : constant Node_Id := Name (N); Scope_Id : Entity_Id; Label_Scope : Entity_Id; + Label_Ent : Entity_Id; begin Check_Unreachable_Code (N); Analyze (Label); + Label_Ent := Entity (Label); - if Entity (Label) = Any_Id then + -- Ignore previous error + + if Label_Ent = Any_Id then return; - elsif Ekind (Entity (Label)) /= E_Label then + -- We just have a label as the target of a goto + + elsif Ekind (Label_Ent) /= E_Label then Error_Msg_N ("target of goto statement must be a label", Label); return; - elsif not Reachable (Entity (Label)) then + -- Check that the target of the goto is reachable according to Ada + -- scoping rules. Note: the special gotos we generate for optimizing + -- local handling of exceptions would violate these rules, but we mark + -- such gotos as analyzed when built, so this code is never entered. + + elsif not Reachable (Label_Ent) then Error_Msg_N ("target of goto statement is not reachable", Label); return; end if; - Label_Scope := Enclosing_Scope (Entity (Label)); + -- Here if goto passes initial validity checks + + Label_Scope := Enclosing_Scope (Label_Ent); for J in reverse 0 .. Scope_Stack.Last loop Scope_Id := Scope_Stack.Table (J).Entity; if Label_Scope = Scope_Id or else (Ekind (Scope_Id) /= E_Block - and then Ekind (Scope_Id) /= E_Loop) + and then Ekind (Scope_Id) /= E_Loop + and then Ekind (Scope_Id) /= E_Return_Statement) then if Scope_Id /= Label_Scope then Error_Msg_N @@ -980,7 +1232,7 @@ package body Sem_Ch5 is Unblocked_Exit_Count := Unblocked_Exit_Count + 1; Analyze_And_Resolve (Cond, Any_Boolean); Check_Unset_Reference (Cond); - Check_Possible_Current_Value_Condition (Cnode); + Set_Current_Value_Condition (Cnode); -- If already deleting, then just analyze then statements @@ -1110,7 +1362,9 @@ package body Sem_Ch5 is -- If the iteration is given by a range, create temporaries and -- assignment statements block to capture the bounds and perform -- required finalization actions in case a bound includes a function - -- call that uses the temporary stack. + -- call that uses the temporary stack. We first pre-analyze a copy of + -- the range in order to determine the expected type, and analyze and + -- resolve the original bounds. procedure Check_Controlled_Array_Attribute (DS : Node_Id); -- If the bounds are given by a 'Range reference on a function call @@ -1124,13 +1378,17 @@ package body Sem_Ch5 is procedure Process_Bounds (R : Node_Id) is Loc : constant Source_Ptr := Sloc (N); + R_Copy : constant Node_Id := New_Copy_Tree (R); Lo : constant Node_Id := Low_Bound (R); Hi : constant Node_Id := High_Bound (R); New_Lo_Bound : Node_Id := Empty; New_Hi_Bound : Node_Id := Empty; - Typ : constant Entity_Id := Etype (R); + Typ : Entity_Id; + Save_Analysis : Boolean; - function One_Bound (Bound : Node_Id) return Node_Id; + function One_Bound + (Original_Bound : Node_Id; + Analyzed_Bound : Node_Id) return Node_Id; -- Create one declaration followed by one assignment statement -- to capture the value of bound. We create a separate assignment -- in order to force the creation of a block in case the bound @@ -1140,45 +1398,43 @@ package body Sem_Ch5 is -- One_Bound -- --------------- - function One_Bound (Bound : Node_Id) return Node_Id is - Assign : Node_Id; - Id : Entity_Id; - Decl : Node_Id; - Decl_Typ : Entity_Id; + function One_Bound + (Original_Bound : Node_Id; + Analyzed_Bound : Node_Id) return Node_Id + is + Assign : Node_Id; + Id : Entity_Id; + Decl : Node_Id; begin - -- If the bound is a constant or an object, no need for a - -- separate declaration. If the bound is the result of previous - -- expansion it is already analyzed and should not be modified. - -- Note that the Bound will be resolved later, if needed, as - -- part of the call to Make_Index (literal bounds may need to - -- be resolved to type Integer). - - if Nkind (Bound) = N_Integer_Literal - or else Is_Entity_Name (Bound) - or else Analyzed (Bound) + -- If the bound is a constant or an object, no need for a separate + -- declaration. If the bound is the result of previous expansion + -- it is already analyzed and should not be modified. Note that + -- the Bound will be resolved later, if needed, as part of the + -- call to Make_Index (literal bounds may need to be resolved to + -- type Integer). + + if Analyzed (Original_Bound) then + return Original_Bound; + + elsif Nkind (Analyzed_Bound) = N_Integer_Literal + or else Is_Entity_Name (Analyzed_Bound) then - return Bound; + Analyze_And_Resolve (Original_Bound, Typ); + return Original_Bound; + + else + Analyze_And_Resolve (Original_Bound, Typ); end if; Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); - -- If the type of the discrete range is Universal_Integer, then - -- the bound's type must be resolved to Integer, so the object - -- used to hold the bound must also have type Integer. - - if Typ = Universal_Integer then - Decl_Typ := Standard_Integer; - else - Decl_Typ := Typ; - end if; - Decl := Make_Object_Declaration (Loc, Defining_Identifier => Id, - Object_Definition => New_Occurrence_Of (Decl_Typ, Loc)); + Object_Definition => New_Occurrence_Of (Typ, Loc)); Insert_Before (Parent (N), Decl); Analyze (Decl); @@ -1186,26 +1442,112 @@ package body Sem_Ch5 is Assign := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Id, Loc), - Expression => Relocate_Node (Bound)); + Expression => Relocate_Node (Original_Bound)); - Save_Interps (Bound, Expression (Assign)); Insert_Before (Parent (N), Assign); Analyze (Assign); - Rewrite (Bound, New_Occurrence_Of (Id, Loc)); + Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); if Nkind (Assign) = N_Assignment_Statement then return Expression (Assign); else - return Bound; + return Original_Bound; end if; end One_Bound; -- Start of processing for Process_Bounds begin - New_Lo_Bound := One_Bound (Lo); - New_Hi_Bound := One_Bound (Hi); + -- Determine expected type of range by analyzing separate copy + -- Do the analysis and resolution of the copy of the bounds with + -- expansion disabled, to prevent the generation of finalization + -- actions on each bound. This prevents memory leaks when the + -- bounds contain calls to functions returning controlled arrays. + + Set_Parent (R_Copy, Parent (R)); + Save_Analysis := Full_Analysis; + Full_Analysis := False; + Expander_Mode_Save_And_Set (False); + + Analyze (R_Copy); + + if Is_Overloaded (R_Copy) then + + -- Apply preference rules for range of predefined integer types, + -- or diagnose true ambiguity. + + declare + I : Interp_Index; + It : Interp; + Found : Entity_Id := Empty; + + begin + Get_First_Interp (R_Copy, I, It); + while Present (It.Typ) loop + if Is_Discrete_Type (It.Typ) then + if No (Found) then + Found := It.Typ; + else + if Scope (Found) = Standard_Standard then + null; + + elsif Scope (It.Typ) = Standard_Standard then + Found := It.Typ; + + else + -- Both of them are user-defined + + Error_Msg_N + ("ambiguous bounds in range of iteration", + R_Copy); + Error_Msg_N ("\possible interpretations:", R_Copy); + Error_Msg_NE ("\\} ", R_Copy, Found); + Error_Msg_NE ("\\} ", R_Copy, It.Typ); + exit; + end if; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + Resolve (R_Copy); + Expander_Mode_Restore; + Full_Analysis := Save_Analysis; + + Typ := Etype (R_Copy); + + -- If the type of the discrete range is Universal_Integer, then + -- the bound's type must be resolved to Integer, and any object + -- used to hold the bound must also have type Integer, unless the + -- literal bounds are constant-folded expressions that carry a user- + -- defined type. + + if Typ = Universal_Integer then + if Nkind (Lo) = N_Integer_Literal + and then Present (Etype (Lo)) + and then Scope (Etype (Lo)) /= Standard_Standard + then + Typ := Etype (Lo); + + elsif Nkind (Hi) = N_Integer_Literal + and then Present (Etype (Hi)) + and then Scope (Etype (Hi)) /= Standard_Standard + then + Typ := Etype (Hi); + + else + Typ := Standard_Integer; + end if; + end if; + + Set_Etype (R, Typ); + + New_Lo_Bound := One_Bound (Lo, Low_Bound (R_Copy)); + New_Hi_Bound := One_Bound (Hi, High_Bound (R_Copy)); -- Propagate staticness to loop range itself, in case the -- corresponding subtype is static. @@ -1290,6 +1632,8 @@ package body Sem_Ch5 is if Present (Cond) then Analyze_And_Resolve (Cond, Any_Boolean); Check_Unset_Reference (Cond); + Set_Current_Value_Condition (N); + return; -- Else we have a FOR loop @@ -1330,7 +1674,6 @@ package body Sem_Ch5 is if Nkind (DS) = N_Range and then Expander_Active then - Pre_Analyze_And_Resolve (DS); Process_Bounds (DS); else Analyze (DS); @@ -1439,13 +1782,15 @@ package body Sem_Ch5 is -- of reversing the bounds incorrectly in the range. elsif Reverse_Present (LP) - and then Nkind (H) = N_Integer_Literal + and then Nkind (Original_Node (H)) = + N_Integer_Literal and then (Intval (H) = Uint_0 or else Intval (H) = Uint_1) and then Lhi > Hhi then Error_Msg_N ("?loop range may be null", DS); + Error_Msg_N ("\?bounds may be wrong way round", DS); end if; end; end if; @@ -1489,8 +1834,9 @@ package body Sem_Ch5 is ---------------------------- procedure Analyze_Loop_Statement (N : Node_Id) is - Id : constant Node_Id := Identifier (N); - Ent : Entity_Id; + Id : constant Node_Id := Identifier (N); + Iter : constant Node_Id := Iteration_Scheme (N); + Ent : Entity_Id; begin if Present (Id) then @@ -1532,11 +1878,264 @@ package body Sem_Ch5 is Kill_Current_Values; New_Scope (Ent); - Analyze_Iteration_Scheme (Iteration_Scheme (N)); + Analyze_Iteration_Scheme (Iter); Analyze_Statements (Statements (N)); Process_End_Label (N, 'e', Ent); End_Scope; Kill_Current_Values; + + -- Check for possible infinite loop which we can diagnose successfully. + -- The case we look for is a while loop which tests a local variable, + -- where there is no obvious direct or indirect update of the variable + -- within the body of the loop. + + -- Note: we don't try to give a warning if condition actions are + -- present, since the loop structure can be very complex in this case. + + if No (Iter) + or else No (Condition (Iter)) + or else Present (Condition_Actions (Iter)) + or else Debug_Flag_Dot_W + then + return; + end if; + + -- Initial conditions met, see if condition is of right form + + declare + Loc : Node_Id := Empty; + Var : Entity_Id := Empty; + + function Has_Indirection (T : Entity_Id) return Boolean; + -- If the controlling variable is an access type, or is a record type + -- with access components, assume that it is changed indirectly and + -- suppress the warning. As a concession to low-level programming, in + -- particular within Declib, we also suppress warnings on a record + -- type that contains components of type Address or Short_Address. + + procedure Find_Var (N : Node_Id); + -- Find whether the condition in a while-loop can be reduced to + -- a test on a single variable. Recurse if condition is negation. + + --------------------- + -- Has_Indirection -- + --------------------- + + function Has_Indirection (T : Entity_Id) return Boolean is + Comp : Entity_Id; + Rec : Entity_Id; + + begin + if Is_Access_Type (T) then + return True; + + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Is_Access_Type (Full_View (T)) + then + return True; + + elsif Is_Record_Type (T) then + Rec := T; + + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Is_Record_Type (Full_View (T)) + then + Rec := Full_View (T); + else + return False; + end if; + + Comp := First_Component (Rec); + while Present (Comp) loop + if Is_Access_Type (Etype (Comp)) + or else Is_Descendent_Of_Address (Etype (Comp)) + then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + end Has_Indirection; + + -------------- + -- Find_Var -- + -------------- + + procedure Find_Var (N : Node_Id) is + begin + -- Condition is a direct variable reference + + if Is_Entity_Name (N) + and then not Is_Library_Level_Entity (Entity (N)) + then + Loc := N; + + -- Case of condition is a comparison with compile time known value + + elsif Nkind (N) in N_Op_Compare then + if Is_Entity_Name (Left_Opnd (N)) + and then Compile_Time_Known_Value (Right_Opnd (N)) + then + Loc := Left_Opnd (N); + + elsif Is_Entity_Name (Right_Opnd (N)) + and then Compile_Time_Known_Value (Left_Opnd (N)) + then + Loc := Right_Opnd (N); + + else + return; + end if; + + -- If condition is a negation, check whether the operand has the + -- proper form. + + elsif Nkind (N) = N_Op_Not then + Find_Var (Right_Opnd (N)); + + -- Case of condition is function call with one parameter + + elsif Nkind (N) = N_Function_Call then + declare + PA : constant List_Id := Parameter_Associations (N); + begin + if Present (PA) + and then List_Length (PA) = 1 + and then Is_Entity_Name (First (PA)) + then + Loc := First (PA); + else + return; + end if; + end; + + else + return; + end if; + end Find_Var; + + begin + Find_Var (Condition (Iter)); + + if Present (Loc) then + Var := Entity (Loc); + end if; + + if Present (Var) + and then Ekind (Var) = E_Variable + and then not Is_Library_Level_Entity (Var) + and then Comes_From_Source (Var) + then + if Has_Indirection (Etype (Var)) then + + -- Assume that the designated object is modified in some + -- other way, to avoid false positives. + + return; + + elsif Is_Volatile (Var) then + + -- If the variable is marked as volatile, we assume that + -- the condition may be affected by other tasks. + + return; + + elsif Nkind (Original_Node (First (Statements (N)))) + = N_Delay_Relative_Statement + or else Nkind (Original_Node (First (Statements (N)))) + = N_Delay_Until_Statement + then + + -- Assume that this is a multitasking program, and the + -- condition is affected by other threads. + + return; + + end if; + + -- There no identifiable single variable in the condition + + else + return; + end if; + + -- Search for reference to variable in loop + + Ref_Search : declare + function Test_Ref (N : Node_Id) return Traverse_Result; + -- Test for reference to variable in question. Returns Abandon + -- if matching reference found. + + function Find_Ref is new Traverse_Func (Test_Ref); + -- Function to traverse body of procedure. Returns Abandon if + -- matching reference found. + + -------------- + -- Test_Ref -- + -------------- + + function Test_Ref (N : Node_Id) return Traverse_Result is + begin + -- Waste of time to look at iteration scheme + + if N = Iter then + return Skip; + + -- Direct reference to variable in question + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then Entity (N) = Var + and then May_Be_Lvalue (N) + then + return Abandon; + + -- Reference to variable renaming variable in question + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then Ekind (Entity (N)) = E_Variable + and then Present (Renamed_Object (Entity (N))) + and then Is_Entity_Name (Renamed_Object (Entity (N))) + and then Entity (Renamed_Object (Entity (N))) = Var + and then May_Be_Lvalue (N) + then + return Abandon; + + -- Calls to subprograms are OK, unless the subprogram is + -- within the scope of the entity in question and could + -- therefore possibly modify it + + elsif Nkind (N) = N_Procedure_Call_Statement + or else Nkind (N) = N_Function_Call + then + if not Is_Entity_Name (Name (N)) + or else Scope_Within (Entity (Name (N)), Scope (Var)) + then + return Abandon; + end if; + end if; + + -- All OK, continue scan + + return OK; + end Test_Ref; + + -- Start of processing for Ref_Search + + begin + if Find_Ref (N) = OK then + Error_Msg_NE + ("variable& is not modified in loop body?", Loc, Var); + Error_Msg_N + ("\possible infinite loop", Loc); + end if; + end Ref_Search; + end; end Analyze_Loop_Statement; ---------------------------- @@ -1626,72 +2225,6 @@ package body Sem_Ch5 is end loop; end Analyze_Statements; - -------------------------------------------- - -- Check_Possible_Current_Value_Condition -- - -------------------------------------------- - - procedure Check_Possible_Current_Value_Condition (Cnode : Node_Id) is - Cond : Node_Id; - - begin - -- Loop to deal with (ignore for now) any NOT operators present - - Cond := Condition (Cnode); - while Nkind (Cond) = N_Op_Not loop - Cond := Right_Opnd (Cond); - end loop; - - -- Check possible relational operator - - if Nkind (Cond) = N_Op_Eq - or else - Nkind (Cond) = N_Op_Ne - or else - Nkind (Cond) = N_Op_Ge - or else - Nkind (Cond) = N_Op_Le - or else - Nkind (Cond) = N_Op_Gt - or else - Nkind (Cond) = N_Op_Lt - then - if Compile_Time_Known_Value (Right_Opnd (Cond)) - and then Nkind (Left_Opnd (Cond)) = N_Identifier - then - declare - Ent : constant Entity_Id := Entity (Left_Opnd (Cond)); - - begin - if Ekind (Ent) = E_Variable - or else - Ekind (Ent) = E_Constant - or else - Is_Formal (Ent) - or else - Ekind (Ent) = E_Loop_Parameter - then - -- Here we have a case where the Current_Value field - -- may need to be set. We set it if it is not already - -- set to a compile time expression value. - - -- Note that this represents a decision that one - -- condition blots out another previous one. That's - -- certainly right if they occur at the same level. - -- If the second one is nested, then the decision is - -- neither right nor wrong (it would be equally OK - -- to leave the outer one in place, or take the new - -- inner one. Really we should record both, but our - -- data structures are not that elaborate. - - if Nkind (Current_Value (Ent)) not in N_Subexpr then - Set_Current_Value (Ent, Cnode); - end if; - end if; - end; - end if; - end if; - end Check_Possible_Current_Value_Condition; - ---------------------------- -- Check_Unreachable_Code -- ----------------------------