[gcc r15-450] ada: Rtsfind should not trash state used in analyzing instantiations.
Marc Poulhi?s
dkm@gcc.gnu.org
Tue May 14 08:23:20 GMT 2024
https://gcc.gnu.org/g:b2453909f68aa3e6810e4995bdcb0a555aab3902
commit r15-450-gb2453909f68aa3e6810e4995bdcb0a555aab3902
Author: Steve Baird <baird@adacore.com>
Date: Wed Feb 7 11:47:22 2024 -0800
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:
---
gcc/ada/rtsfind.adb | 9 +++++++-
gcc/ada/sem_ch12.adb | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++
gcc/ada/sem_ch12.ads | 25 +++++++++++++++++++++
gcc/ada/table.ads | 2 +-
4 files changed, 96 insertions(+), 2 deletions(-)
diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb
index 8933ca6ce168..7c9935e614c2 100644
--- 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 cb05a71e96f9..4ceddda20526 100644
--- 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 79f8c56c5450..6639d546e316 100644
--- 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 567d651259c9..5e700b009cb5 100644
--- 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
More information about the Gcc-cvs
mailing list