diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d9f0784f389..e75e4ee8b4f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,33 @@ +2009-07-22 Thomas Quinot + + * sem_elab.adb (Insert_Elab_Check): When relocating an overloaded + expression to insert an elab check using a conditional expression, be + sure to carry the original list of interpretations to the new location. + +2009-07-22 Gary Dismukes + + * gnat1drv.adb: Fix spelling error. + +2009-07-22 Javier Miranda + + * sem_type.ads, sem_type.adb (In_Generic_Actual): Leave this subprogram + at the library level and fix a hidden bug in its implementation: its + functionality for renaming objects was broken because + N_Object_Renaming_Declarations nodes are not a subclass of + N_Declaration nodes (as documented in sinfo.ads). + * sem_util.adb (Check_Dynamically_Tagged_Expression): Include in this + check nodes that are actuals of generic instantiations. + +2009-07-22 Ed Schonberg + + * sinfo.ads, sinfo.adb (Pending_Context): New flag to indicate that the + context of a compilation unit is being analyzed. Used to detect + circularities created by with_clauses that are not detected by the + loading machinery. + * sem_ch10.adb (Analyze_Compilation_Unit): Set Pending_Context before + analyzing the context of the current compilation unit, to detect + possible circularities created by with_clauses. + 2009-07-22 Thomas Quinot * sem_type.adb (Get_First_Interp): Fix wrong loop exit condition. diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 0e7fd15b74b..6b4ef9a5701 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -159,7 +159,7 @@ procedure Gnat1drv is ASIS_Mode := False; -- Suppress overflow checks and access checks since they are handled - -- implicitely by CodePeer. + -- implicitly by CodePeer. -- Turn off dynamic elaboration checks: generates inconsistencies in -- trees between specs compiled as part of a main unit or as part of diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 687dd5c2f9a..88edbcc56e2 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -661,9 +661,59 @@ package body Sem_Ch10 is end if; -- Analyze context (this will call Sem recursively for with'ed units) + -- To detect circularities among with-clauses that are not caught during + -- loading, we set the Context_Pending flag on the current unit. If the + -- flag is already set there is a potential circularity. + -- We exclude predefined units from this check because they are known + -- to be safe. we also exclude package bodies that are present because + -- circularities between bodies are harmless (and necessary). + + if Context_Pending (N) then + declare + Circularity : Boolean := True; + + begin + if Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Unit (N)))) + then + Circularity := False; + + else + for U in Main_Unit + 1 .. Last_Unit loop + if Nkind (Unit (Cunit (U))) = N_Package_Body + and then not Analyzed (Cunit (U)) + then + Circularity := False; + exit; + end if; + end loop; + end if; + + if Circularity then + Error_Msg_N + ("circular dependency caused by with_clauses", N); + Error_Msg_N + ("\possibly missing limited_with clause" + & " in one of the following", N); + + for U in Main_Unit .. Last_Unit loop + if Context_Pending (Cunit (U)) then + Error_Msg_Unit_1 := Get_Unit_Name (Unit (Cunit (U))); + Error_Msg_N ("\unit$", N); + end if; + end loop; + + raise Unrecoverable_Error; + end if; + end; + else + Set_Context_Pending (N); + end if; Analyze_Context (N); + Set_Context_Pending (N, False); + -- If the unit is a package body, the spec is already loaded and must be -- analyzed first, before we analyze the body. diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 60a07322dc4..1e278a6bb58 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -47,6 +47,7 @@ with Sem_Cat; use Sem_Cat; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; @@ -939,9 +940,7 @@ package body Sem_Elab is Insert_Elab_Check (N, Make_Attribute_Reference (Loc, Attribute_Name => Name_Elaborated, - Prefix => - New_Occurrence_Of - (Spec_Entity (E_Scope), Loc))); + Prefix => New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); end if; -- Case of static elaboration model @@ -2415,8 +2414,7 @@ package body Sem_Elab is Make_Attribute_Reference (Loc, Attribute_Name => Name_Elaborated, Prefix => - New_Occurrence_Of - (Spec_Entity (Task_Scope), Loc))); + New_Occurrence_Of (Spec_Entity (Task_Scope), Loc))); end if; else @@ -2852,6 +2850,8 @@ package body Sem_Elab is Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); + Reloc_N : Node_Id; + begin Set_Etype (R, Typ); @@ -2859,9 +2859,11 @@ package body Sem_Elab is Rewrite (N, R); else + Reloc_N := Relocate_Node (N); + Save_Interps (N, Reloc_N); Rewrite (N, Make_Conditional_Expression (Loc, - Expressions => New_List (C, Relocate_Node (N), R))); + Expressions => New_List (C, Reloc_N, R))); end if; Analyze_And_Resolve (N, Typ); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 8beb56faea4..931112c472d 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -1147,8 +1147,7 @@ package body Sem_Type is function Disambiguate (N : Node_Id; I1, I2 : Interp_Index; - Typ : Entity_Id) - return Interp + Typ : Entity_Id) return Interp is I : Interp_Index; It : Interp; @@ -1161,13 +1160,6 @@ package body Sem_Type is -- Determine whether one of the candidates is an operation inherited by -- a type that is derived from an actual in an instantiation. - function In_Generic_Actual (Exp : Node_Id) return Boolean; - -- Determine whether the expression is part of a generic actual. At - -- the time the actual is resolved the scope is already that of the - -- instance, but conceptually the resolution of the actual takes place - -- in the enclosing context, and no special disambiguation rules should - -- be applied. - function Is_Actual_Subprogram (S : Entity_Id) return Boolean; -- Determine whether a subprogram is an actual in an enclosing instance. -- An overloading between such a subprogram and one declared outside the @@ -1204,34 +1196,6 @@ package body Sem_Type is -- for special handling of expressions with universal operands, see -- comments to Has_Abstract_Interpretation below. - ----------------------- - -- In_Generic_Actual -- - ----------------------- - - function In_Generic_Actual (Exp : Node_Id) return Boolean is - Par : constant Node_Id := Parent (Exp); - - begin - if No (Par) then - return False; - - elsif Nkind (Par) in N_Declaration then - if Nkind (Par) = N_Object_Declaration - or else Nkind (Par) = N_Object_Renaming_Declaration - then - return Present (Corresponding_Generic_Association (Par)); - else - return False; - end if; - - elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then - return False; - - else - return In_Generic_Actual (Parent (Par)); - end if; - end In_Generic_Actual; - --------------------------- -- Inherited_From_Actual -- --------------------------- @@ -1260,7 +1224,7 @@ package body Sem_Type is return In_Open_Scopes (Scope (S)) and then (Is_Generic_Instance (Scope (S)) - or else Is_Wrapper_Package (Scope (S))); + or else Is_Wrapper_Package (Scope (S))); end Is_Actual_Subprogram; ------------- @@ -1274,8 +1238,7 @@ package body Sem_Type is return T1 = T2 or else (Is_Numeric_Type (T2) - and then - (T1 = Universal_Real or else T1 = Universal_Integer)); + and then (T1 = Universal_Real or else T1 = Universal_Integer)); end Matches; ------------------------ @@ -1417,9 +1380,8 @@ package body Sem_Type is elsif Present (Act2) and then Nkind (Act2) in N_Op and then Is_Overloaded (Act2) - and then (Nkind (Right_Opnd (Act2)) = N_Integer_Literal - or else - Nkind (Right_Opnd (Act2)) = N_Real_Literal) + and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal, + N_Real_Literal) and then Has_Compatible_Type (Act2, Standard_Boolean) then -- The preference rule on the first actual is not @@ -2526,6 +2488,35 @@ package body Sem_Type is return Typ; end Intersect_Types; + ----------------------- + -- In_Generic_Actual -- + ----------------------- + + function In_Generic_Actual (Exp : Node_Id) return Boolean is + Par : constant Node_Id := Parent (Exp); + + begin + if No (Par) then + return False; + + elsif Nkind (Par) in N_Declaration then + if Nkind (Par) = N_Object_Declaration then + return Present (Corresponding_Generic_Association (Par)); + else + return False; + end if; + + elsif Nkind (Par) = N_Object_Renaming_Declaration then + return Present (Corresponding_Generic_Association (Par)); + + elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then + return False; + + else + return In_Generic_Actual (Parent (Par)); + end if; + end In_Generic_Actual; + ----------------- -- Is_Ancestor -- ----------------- diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads index cfbc579bf08..307674fce14 100644 --- a/gcc/ada/sem_type.ads +++ b/gcc/ada/sem_type.ads @@ -211,6 +211,12 @@ package Sem_Type is -- interpretations is universal, choose the non-universal one. If either -- node is overloaded, find single common interpretation. + function In_Generic_Actual (Exp : Node_Id) return Boolean; + -- Determine whether the expression is part of a generic actual. At the + -- time the actual is resolved the scope is already that of the instance, + -- but conceptually the resolution of the actual takes place in the + -- enclosing context and no special disambiguation rules should be applied. + function Is_Ancestor (T1, T2 : Entity_Id) return Boolean; -- T1 is a tagged type (not class-wide). Verify that it is one of the -- ancestors of type T2 (which may or not be class-wide). diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3e3c03a0f10..2e130b2fdc7 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1045,7 +1045,12 @@ package body Sem_Util is begin pragma Assert (Is_Tagged_Type (Typ)); - if Comes_From_Source (Related_Nod) + -- In order to avoid spurious errors when analyzing the expanded code + -- this check is done only for nodes that come from source and for + -- actuals of generic instantiations + + if (Comes_From_Source (Related_Nod) + or else In_Generic_Actual (Expr)) and then (Is_Class_Wide_Type (Etype (Expr)) or else Is_Dynamically_Tagged (Expr)) and then Is_Tagged_Type (Typ) diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index da6adb20072..7bd9553798a 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -549,6 +549,14 @@ package body Sinfo is return List1 (N); end Context_Items; + function Context_Pending + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + return Flag16 (N); + end Context_Pending; + function Controlling_Argument (N : Node_Id) return Node_Id is begin @@ -3364,6 +3372,14 @@ package body Sinfo is Set_List1_With_Parent (N, Val); end Set_Context_Items; + procedure Set_Context_Pending + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + Set_Flag16 (N, Val); + end Set_Context_Pending; + procedure Set_Controlling_Argument (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 737f7b66bb3..e7b25230e73 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -698,6 +698,13 @@ package Sinfo is -- package Exp_Util, and also the expansion routines for the relevant -- nodes. + -- Context_Pending (Flag16-Sem) + -- This field appears in Compilation_Unit nodes, to indicate that the + -- context of the unit is being compiled. Used to detect circularities + -- that are not otherwise detected by the loading mechanism. Such + -- circularities can occur in the presence of limited and non-limited + -- with_clauses that mention the same units. + -- Controlling_Argument (Node1-Sem) -- This field is set in procedure and function call nodes if the call -- is a dispatching call (it is Empty for a non-dispatching call). It @@ -5393,6 +5400,7 @@ package Sinfo is -- Has_No_Elaboration_Code (Flag17-Sem) -- Body_Required (Flag13-Sem) set for spec if body is required -- Acts_As_Spec (Flag4-Sem) flag for subprogram body with no spec + -- Context_Pending (Flag16-Sem) -- First_Inlined_Subprogram (Node3-Sem) -- N_Compilation_Unit_Aux @@ -7678,6 +7686,9 @@ package Sinfo is function Context_Installed (N : Node_Id) return Boolean; -- Flag13 + function Context_Pending + (N : Node_Id) return Boolean; -- Flag16 + function Context_Items (N : Node_Id) return List_Id; -- List1 @@ -8578,6 +8589,9 @@ package Sinfo is procedure Set_Context_Items (N : Node_Id; Val : List_Id); -- List1 + procedure Set_Context_Pending + (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Controlling_Argument (N : Node_Id; Val : Node_Id); -- Node1 @@ -11009,6 +11023,7 @@ package Sinfo is pragma Inline (Constraints); pragma Inline (Context_Installed); pragma Inline (Context_Items); + pragma Inline (Context_Pending); pragma Inline (Controlling_Argument); pragma Inline (Conversion_OK); pragma Inline (Corresponding_Body); @@ -11305,6 +11320,7 @@ package Sinfo is pragma Inline (Set_Constraints); pragma Inline (Set_Context_Installed); pragma Inline (Set_Context_Items); + pragma Inline (Set_Context_Pending); pragma Inline (Set_Controlling_Argument); pragma Inline (Set_Conversion_OK); pragma Inline (Set_Corresponding_Body);