2009-07-22 Thomas Quinot <quinot@adacore.com>

	* 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  <dismukes@adacore.com>

	* gnat1drv.adb: Fix spelling error.

2009-07-22  Javier Miranda  <miranda@adacore.com>

	* 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  <schonberg@adacore.com>

	* 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.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149925 138bc75d-0d04-0410-961f-82ee72b054a4

9 files changed, 167 insertions, 51 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d9f0784f389..e75e4ee8b4f 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,35 @@
 2009-07-22  Thomas Quinot  <quinot@adacore.com>
 
+	* 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  <dismukes@adacore.com>
+
+	* gnat1drv.adb: Fix spelling error.
+
+2009-07-22  Javier Miranda  <miranda@adacore.com>
+
+	* 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  <schonberg@adacore.com>
+
+	* 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  <quinot@adacore.com>
+
 	* sem_type.adb (Get_First_Interp): Fix wrong loop exit condition.
 
 2009-07-22  Robert Dewar  <dewar@adacore.com>
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);