sinfo.ads, sinfo.adb: New attribute Next_Implicit_With...

2009-04-29  Ed Schonberg  <schonberg@adacore.com>

	* sinfo.ads, sinfo.adb: New attribute Next_Implicit_With, to chain
	with_clauses generated for the same unit through rtsfind, and that
	appear in the context of different units.

	* rtsfind.adb: New attribute First_Implicit_With, component of the
	Unit_Record that stores information about a unit loaded through rtsfind.

From-SVN: r146951

4 files changed, 92 insertions, 55 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index aacaa58..cfa9a88 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2009-04-29  Ed Schonberg  <schonberg@adacore.com>
+
+	* sinfo.ads, sinfo.adb: New attribute Next_Implicit_With, to chain
+	with_clauses generated for the same unit through rtsfind, and that
+	appear in the context of different units.
+
+	* rtsfind.adb: New attribute First_Implicit_With, component of the
+	Unit_Record that stores information about a unit loaded through rtsfind.
+
 2009-04-29  Gary Dismukes  <dismukes@adacore.com>
 
 	* exp_ch3.adb (Stream_Operation_OK): Return True for limited interfaces
diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb
index 629aae2..d05aef0 100644
--- a/gcc/ada/rtsfind.adb
+++ b/gcc/ada/rtsfind.adb
@@ -79,16 +79,18 @@ package body Rtsfind is
    --  the latter case it is critical to make a call to Set_RTU_Loaded to
    --  ensure that the entry in this table reflects the load.
 
-   --  Withed is True if an implicit with_clause has been added from some unit
-   --  other than the main unit to this unit. Withed_By_Main is the same,
-   --  except from the main unit.
+   --  A unit retrieved through rtsfind  may end up in the context of several
+   --  other units, in addition to the main unit. These additional with_clauses
+   --  are needed to generate a proper traversal order for Inspector. To
+   --  minimize somewhat the redundancy created by numerous calls to rtsfind
+   --  from different units, we keep track of the list of implicit with_clauses
+   --  already created for the current loaded unit.
 
    type RT_Unit_Table_Record is record
-      Entity         : Entity_Id;
-      Uname          : Unit_Name_Type;
-      Unum           : Unit_Number_Type;
-      Withed         : Boolean;
-      Withed_By_Main : Boolean;
+      Entity               : Entity_Id;
+      Uname                : Unit_Name_Type;
+      First_Implicit_With  : Node_Id;
+      Unum                 : Unit_Number_Type;
    end record;
 
    RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record;
@@ -118,12 +120,12 @@ package body Rtsfind is
    --  When a unit is implicitly loaded as a result of a call to RTE, it is
    --  necessary to create one or two implicit with_clauses. We add such
    --  with_clauses to the extended main unit if needed, and also to whatever
-   --  unit first needs them, which is not necessarily the main unit. The
-   --  former ensures that the object is correctly loaded by the binder. The
-   --  latter is necessary for SofCheck Inspector.
+   --  unit needs them, which is not necessarily the main unit. The former
+   --  ensures that the object is correctly loaded by the binder. The latter
+   --  is necessary for SofCheck Inspector.
 
-   --  The flags Withed and Withed_By_Main in the unit table record are used to
-   --  avoid duplicates.
+   --  The field First_Implicit_With in the unit table record are used to
+   --  avoid creating duplicate with_clauses.
 
    -----------------------
    -- Local Subprograms --
@@ -668,9 +670,8 @@ package body Rtsfind is
       --  Otherwise we need to load the unit, First build unit name
       --  from the enumeration literal name in type RTU_Id.
 
-      U.Uname          := Get_Unit_Name (U_Id);
-      U.Withed         := False;
-      U.Withed_By_Main := False;
+      U.Uname                := Get_Unit_Name (U_Id);
+      U. First_Implicit_With := Empty;
 
       --  Now do the load call, note that setting Error_Node to Empty is
       --  a signal to Load_Unit that we will regard a failure to find the
@@ -798,9 +799,6 @@ package body Rtsfind is
    --------------------
 
    procedure Maybe_Add_With (U : in out RT_Unit_Table_Record) is
-      Is_Main : constant Boolean :=
-                  In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit));
-
    begin
       --  We do not need to generate a with_clause for a call issued from
       --  RTE_Component_Available. However, for Inspector, we need these
@@ -818,42 +816,37 @@ package body Rtsfind is
          return;
       end if;
 
-      --  If the current unit is the main one, add the with_clause unless it's
-      --  already been done.
+      --  Add the with_clause, if not already in the context of the
+      --  current compilation unit.
 
-      if Is_Main then
-         if U.Withed_By_Main then
-            return;
-         else
-            U.Withed_By_Main := True;
-         end if;
+      declare
+         LibUnit : constant Node_Id := Unit (Cunit (U.Unum));
+         Clause  : Node_Id;
+         Withn   : Node_Id;
 
-      --  If the current unit is not the main one, add the with_clause unless
-      --  it's already been done for some non-main unit.
+      begin
+         Clause := U.First_Implicit_With;
+         while Present (Clause) loop
+            if Parent (Clause) =  Cunit (Current_Sem_Unit) then
+               return;
+            end if;
 
-      else
-         if U.Withed then
-            return;
-         else
-            U.Withed := True;
-         end if;
-      end if;
+            Clause := Next_Implicit_With (Clause);
+         end loop;
 
-      --  Here if we've decided to add the with_clause
+         Withn :=
+            Make_With_Clause (Standard_Location,
+              Name =>
+                Make_Unit_Name
+                  (U, Defining_Unit_Name (Specification (LibUnit))));
 
-      declare
-         LibUnit : constant Node_Id := Unit (Cunit (U.Unum));
-         Withn   : constant Node_Id :=
-                     Make_With_Clause (Standard_Location,
-                       Name =>
-                         Make_Unit_Name
-                           (U, Defining_Unit_Name (Specification (LibUnit))));
+         Set_Library_Unit        (Withn, Cunit (U.Unum));
+         Set_Corresponding_Spec  (Withn, U.Entity);
+         Set_First_Name          (Withn, True);
+         Set_Implicit_With       (Withn, True);
+         Set_Next_Implicit_With  (Withn, U.First_Implicit_With);
 
-      begin
-         Set_Library_Unit       (Withn, Cunit (U.Unum));
-         Set_Corresponding_Spec (Withn, U.Entity);
-         Set_First_Name         (Withn, True);
-         Set_Implicit_With      (Withn, True);
+         U.First_Implicit_With := Withn;
 
          Mark_Rewrite_Insertion (Withn);
          Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
@@ -1342,14 +1335,14 @@ package body Rtsfind is
                --  The RT_Unit_Table entry that may need updating
 
             begin
-               --  If entry is not set, set it now
+               --  If entry is not set, set it now, and indicate that it
+               --  was loaded through an explicit context clause..
 
                if No (U.Entity) then
-                  U := (Entity         => E,
-                        Uname          => Get_Unit_Name (U_Id),
-                        Unum           => Unum,
-                        Withed         => False,
-                        Withed_By_Main => False);
+                  U := (Entity               => E,
+                        Uname                => Get_Unit_Name (U_Id),
+                        Unum                 => Unum,
+                        First_Implicit_With  => Empty);
                end if;
 
                return;
diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index 59ddd5c..30ba980 100644
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.adb
@@ -1979,6 +1979,14 @@ package body Sinfo is
       return Node2 (N);
    end Next_Entity;
 
+   function Next_Implicit_With
+     (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      return Node3 (N);
+   end Next_Implicit_With;
+
    function Next_Named_Actual
       (N : Node_Id) return Node_Id is
    begin
@@ -4759,6 +4767,14 @@ package body Sinfo is
       Set_Node2 (N, Val); -- semantic field, no parent set
    end Set_Next_Entity;
 
+   procedure Set_Next_Implicit_With
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      Set_Node3 (N, Val); -- semantic field, no parent set
+   end Set_Next_Implicit_With;
+
    procedure Set_Next_Named_Actual
       (N : Node_Id; Val : Node_Id) is
    begin
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 5aae9c0..7325b76 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -1364,6 +1364,16 @@ package Sinfo is
    --    scope are chained, and this field is used as the forward pointer for
    --    this list. See Einfo for further details.
 
+   --  Next_Implicit_With (Node3-Sem)
+   --    Present in N_With_Clause. Part of a chain of with_clauses generated
+   --    in rtsfind to indicate implicit dependencies on predefined units. Used
+   --    to prevent multiple with_clauses for the same unit in a given context.
+   --    A postorder traversal of the tree whose nodes are units and whose
+   --    links are with_clauses defines the order in which Inspector must
+   --    examine a compiled unit and its full context. This ordering ensures
+   --    that any subprogram call is examined after the subprogram declartion
+   --    has been seen.
+
    --  Next_Named_Actual (Node4-Sem)
    --    Present in parameter association node. Set during semantic analysis to
    --    point to the next named parameter, where parameters are ordered by
@@ -5450,6 +5460,7 @@ package Sinfo is
       --  N_With_Clause
       --  Sloc points to first token of library unit name
       --  Name (Node2)
+      --  Next_Implicit_With (Node3-Sem)
       --  Library_Unit (Node4-Sem)
       --  Corresponding_Spec (Node5-Sem)
       --  First_Name (Flag5) (set to True if first name or only one name)
@@ -8062,6 +8073,9 @@ package Sinfo is
    function Next_Entity
      (N : Node_Id) return Node_Id;    -- Node2
 
+   function Next_Implicit_With
+     (N : Node_Id) return Node_Id;    -- Node3
+
    function Next_Named_Actual
      (N : Node_Id) return Node_Id;    -- Node4
 
@@ -8947,6 +8961,9 @@ package Sinfo is
    procedure Set_Next_Entity
      (N : Node_Id; Val : Node_Id);            -- Node2
 
+   procedure Set_Next_Implicit_With
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
    procedure Set_Next_Named_Actual
      (N : Node_Id; Val : Node_Id);            -- Node4
 
@@ -11064,6 +11081,7 @@ package Sinfo is
    pragma Inline (Name);
    pragma Inline (Names);
    pragma Inline (Next_Entity);
+   pragma Inline (Next_Implicit_With);
    pragma Inline (Next_Named_Actual);
    pragma Inline (Next_Pragma);
    pragma Inline (Next_Rep_Item);
@@ -11356,6 +11374,7 @@ package Sinfo is
    pragma Inline (Set_Name);
    pragma Inline (Set_Names);
    pragma Inline (Set_Next_Entity);
+   pragma Inline (Set_Next_Implicit_With);
    pragma Inline (Set_Next_Named_Actual);
    pragma Inline (Set_Next_Pragma);
    pragma Inline (Set_Next_Rep_Item);