ada: Rtsfind should not trash state used in analyzing instantiations.

During analysis of an instantiation, Sem_Ch12 manages formal/actual binding
information in package state (see Sem_Ch12.Generic_Renamings_HTable).
A call to rtsfind can cause another unit to be loaded and compiled.
If this occurs during the analysis of an instantiation, and if the loaded
unit contains a second instantiation, then the Sem_Ch12 state needed for
analyzing the first instantiation can be trashed during the analysis of the
second instantiation. Rtsfind calls that can include the analysis of an
instantiation need to save and restore Sem_Ch12's state.

gcc/ada/

	* sem_ch12.ads: Declare new Instance_Context package, which
	declares a private type Context with operations Save_And_Reset and
	Restore.
	* sem_ch12.adb: Provide body for new Instance_Context package.
	* rtsfind.adb (Load_RTU): Wrap an Instance_Context Save/Restore
	call pair around the call to Semantics.
	* table.ads: Add initial value for Last_Val (because
	Save_And_Reset expects Last_Val to be initialized).

diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb
index 8933ca6ce168429c339c4597000af01e8add0ff5..7c9935e614c222f325475804dc21cf68db04b4ad 100644 (file)
--- a/gcc/ada/rtsfind.adb
+++ b/gcc/ada/rtsfind.adb
@@ -47,6 +47,7 @@ with Restrict;       use Restrict;
 with Sem;            use Sem;
 with Sem_Aux;        use Sem_Aux;
 with Sem_Ch7;        use Sem_Ch7;
+with Sem_Ch12;        use Sem_Ch12;
 with Sem_Dist;       use Sem_Dist;
 with Sem_Util;       use Sem_Util;
 with Sinfo;          use Sinfo;
@@ -1185,7 +1186,13 @@ package body Rtsfind is
 
             else
                Save_Private_Visibility;
-               Semantics (Cunit (U.Unum));
+               declare
+                  Saved_Instance_Context : constant Instance_Context.Context
+                    := Instance_Context.Save_And_Reset;
+               begin
+                  Semantics (Cunit (U.Unum));
+                  Instance_Context.Restore (Saved_Instance_Context);
+               end;
                Restore_Private_Visibility;
 
                if Fatal_Error (U.Unum) = Error_Detected then

diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index cb05a71e96f9ba2d07cd1eeb61611540fcac0fea..4ceddda205266081e9bc3571658fb3264ce982aa 100644 (file)
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -17753,4 +17753,66 @@ package body Sem_Ch12 is
             raise Program_Error;
       end case;
    end Validate_Formal_Type_Default;
+
+   package body Instance_Context is
+
+      --------------------
+      -- Save_And_Reset --
+      --------------------
+
+      function Save_And_Reset return Context is
+      begin
+         return Result : Context (0 .. Integer (Generic_Renamings.Last)) do
+            for Index in Result'Range loop
+               declare
+                  Indexed_Assoc : Assoc renames Generic_Renamings.Table
+                                                  (Assoc_Ptr (Index));
+                  Result_Pair : Binding_Pair renames Result (Index);
+               begin
+                  --  If we have called Increment_Last but have not yet
+                  --  initialized the new last element of the table, then
+                  --  that last element might be invalid. Saving and
+                  --  restoring (especially restoring, it turns out) invalid
+                  --  values can result in exceptions if predicate checking
+                  --  is enabled, so replace invalid values with Empty.
+
+                  if Indexed_Assoc.Gen_Id'Valid then
+                     Result_Pair.Formal_Id := Indexed_Assoc.Gen_Id;
+                  else
+                     pragma Assert (Index = Result'Last);
+                     Result_Pair.Formal_Id := Empty;
+                  end if;
+
+                  if Indexed_Assoc.Act_Id'Valid then
+                     Result_Pair.Actual_Id := Indexed_Assoc.Act_Id;
+                  else
+                     pragma Assert (Index = Result'Last);
+                     Result_Pair.Actual_Id := Empty;
+                  end if;
+               end;
+            end loop;
+
+            Generic_Renamings.Init;
+            Generic_Renamings.Set_Last (0);
+            Generic_Renamings_HTable.Reset;
+         end return;
+      end Save_And_Reset;
+
+      -------------
+      -- Restore --
+      -------------
+
+      procedure Restore (Saved : Context) is
+      begin
+         Generic_Renamings.Init;
+         Generic_Renamings.Set_Last (0);
+         Generic_Renamings_HTable.Reset;
+         Generic_Renamings.Increment_Last;
+         for Pair of Saved loop
+            Set_Instance_Of (Pair.Formal_Id, Pair.Actual_Id);
+         end loop;
+         Generic_Renamings.Decrement_Last;
+      end Restore;
+
+   end Instance_Context;
 end Sem_Ch12;

diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads
index 79f8c56c5450ab224a31d8bbb017978c2656e0be..6639d546e3169d32b574e22fb45cb7c7878e12cf 100644 (file)
--- a/gcc/ada/sem_ch12.ads
+++ b/gcc/ada/sem_ch12.ads
@@ -193,6 +193,31 @@ package Sem_Ch12 is
    --  After processing an instantiation, or aborting one because of semantic
    --  errors, remove the current Instantiation_Env from Instantation_Envs.
 
+   package Instance_Context is
+      --  If an entirely new context is entered (e.g., when Rtsfind invokes
+      --  semantics on a new compilation unit), then the current contents of
+      --  the generic renamings table must be saved and later restored.
+
+      type Context (<>) is private;
+
+      function Save_And_Reset return Context;
+      --  Save the current context information, then reinitialize
+      --  the current context, and finally return the saved value.
+
+      procedure Restore (Saved : Context);
+      --  Restore the context that was saved earlier.
+
+   private
+
+      type Binding_Pair is record
+         Formal_Id : Entity_Id;
+         Actual_Id : Entity_Id;
+      end record;
+
+      type Context is array (Natural range <>) of Binding_Pair;
+
+   end Instance_Context;
+
    procedure Initialize;
    --  Initializes internal data structures
 

diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads
index 567d651259c9b88908c9328e2b2ec239ca593538..5e700b009cb5a2cd6da928c75840d3f01c08dbfd 100644 (file)
--- a/gcc/ada/table.ads
+++ b/gcc/ada/table.ads
@@ -217,7 +217,7 @@ package Table is
 
    private
 
-      Last_Val : Int;
+      Last_Val : Int := Int (Table_Low_Bound) - 1;
       --  Current value of Last. Note that we declare this in the private part
       --  because we don't want the client to modify Last except through one of
       --  the official interfaces (since a modification to Last may require a