From: Ed Schonberg Date: Fri, 6 Apr 2007 09:26:37 +0000 (+0200) Subject: sem_ch5.adb (Analyze_Assignment): Reject a right-hand side that is a tag-indeterminat... X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=b6a1a16fbda2a0dbcf8095ff57b692f01449fceb;p=platform%2Fupstream%2Fgcc.git sem_ch5.adb (Analyze_Assignment): Reject a right-hand side that is a tag-indeterminate call to an abstract... 2007-04-06 Ed Schonberg Robert Dewar * sem_ch5.adb (Analyze_Assignment): Reject a right-hand side that is a tag-indeterminate call to an abstract function, when the left-hand side is not classwide. (Analyze_Loop_Statement): Improve detection of infinite loops From-SVN: r123595 --- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index f74cfa9..d95634f 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -517,10 +517,27 @@ package body Sem_Ch5 is -- Propagate the tag from a class-wide target to the rhs when the rhs -- is a tag-indeterminate call. - if Is_Class_Wide_Type (T1) - and then Is_Tag_Indeterminate (Rhs) - then - Propagate_Tag (Lhs, 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 @@ -1117,25 +1134,38 @@ 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); + + -- Ignore previous error - if Entity (Label) = Any_Id then + 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; @@ -1873,65 +1903,162 @@ package body Sem_Ch5 is -- Initial conditions met, see if condition is of right form declare - Cond : constant Node_Id := Condition (Iter); - Var : Entity_Id; - Loc : Node_Id; + Loc : Node_Id := Empty; + Var : Entity_Id := Empty; - begin - -- Condition is a direct variable reference + 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. - if Is_Entity_Name (Cond) - and then not Is_Library_Level_Entity (Entity (Cond)) - then - Loc := Cond; + 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. - -- Case of condition is a comparison with compile time known value + --------------------- + -- Has_Indirection -- + --------------------- - elsif Nkind (Cond) in N_Op_Compare then - if Is_Entity_Name (Left_Opnd (Cond)) - and then Compile_Time_Known_Value (Right_Opnd (Cond)) - then - Loc := Left_Opnd (Cond); + 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_Entity_Name (Right_Opnd (Cond)) - and then Compile_Time_Known_Value (Left_Opnd (Cond)) + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Is_Access_Type (Full_View (T)) then - Loc := Right_Opnd (Cond); + 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; + return False; end if; - -- Case of condition is function call with one parameter + 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; - elsif Nkind (Cond) = N_Function_Call then - declare - PA : constant List_Id := Parameter_Associations (Cond); - begin - if Present (PA) - and then List_Length (PA) = 1 - and then Is_Entity_Name (First (PA)) + 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 := First (PA); + Loc := Right_Opnd (N); + else return; end if; - end; - else - return; - end if; + -- If condition is a negation, check whether the operand has the + -- proper form. - -- If we fall through Loc is set to the node that is an entity ref + elsif Nkind (N) = N_Op_Not then + Find_Var (Right_Opnd (N)); - Var := Entity (Loc); + -- 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 - null; + 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; @@ -1979,13 +2106,15 @@ package body Sem_Ch5 is then return Abandon; - -- Check for call to other than library level subprogram + -- 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 not Is_Library_Level_Entity (Entity (Name (N))) + or else Scope_Within (Entity (Name (N)), Scope (Var)) then return Abandon; end if;