This patch reimplements the way the front end detects whether a type is a
descendant of Ada.Synchronous_Task_Control.Suspension_Object to avoid using
the RTSfind mechanism. This ensures that external clients of the front end
will not fail due to a locked scope table accessed during analysis performed
by RTSfind.
No reproducer possible as this requires an external front end client.
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-10-20 Hristian Kirtchev <[email protected]>
* rtsfind.ads Remove the entries for Ada.Synchronous_Task_Control
and Suspension_Object from tables RE_Id, RE_Unit_Table and RTU_Id.
* sem_util.adb (Is_Descendant_Of_Suspension_Object): Update
the comment on usage. Use routine Is_Suspension_Object to detect
whether a type matches Suspension_Object.
(Is_Suspension_Object): New routine.
* snames.ads-tmpl: Add predefined names for Suspension_Object
and Synchronous_Task_Control.
Index: rtsfind.ads
===================================================================
--- rtsfind.ads (revision 229047)
+++ rtsfind.ads (working copy)
@@ -131,7 +131,6 @@
Ada_Real_Time,
Ada_Streams,
Ada_Strings,
- Ada_Synchronous_Task_Control,
Ada_Tags,
Ada_Task_Identification,
Ada_Task_Termination,
@@ -607,8 +606,6 @@
RE_Unbounded_String, -- Ada.Strings.Unbounded
- RE_Suspension_Object, -- Ada.Synchronous_Task_Control
-
RE_Access_Level, -- Ada.Tags
RE_Alignment, -- Ada.Tags
RE_Address_Array, -- Ada.Tags
@@ -1840,8 +1837,6 @@
RE_Unbounded_String => Ada_Strings_Unbounded,
- RE_Suspension_Object => Ada_Synchronous_Task_Control,
-
RE_Access_Level => Ada_Tags,
RE_Alignment => Ada_Tags,
RE_Address_Array => Ada_Tags,
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 229047)
+++ sem_util.adb (working copy)
@@ -11397,9 +11397,7 @@
function Is_Descendant_Of_Suspension_Object
(Typ : Entity_Id) return Boolean;
-- Determine whether type Typ is a descendant of type Suspension_Object
- -- defined in Ada.Synchronous_Task_Control. This routine is similar to
- -- Sem_Util.Is_Descendent_Of, however this version does not load unit
- -- Ada.Synchronous_Task_Control.
+ -- defined in Ada.Synchronous_Task_Control.
----------------------------------------
-- Is_Descendant_Of_Suspension_Object --
@@ -11408,24 +11406,39 @@
function Is_Descendant_Of_Suspension_Object
(Typ : Entity_Id) return Boolean
is
- Cur_Typ : Entity_Id;
- Par_Typ : Entity_Id;
+ function Is_Suspension_Object (Id : Entity_Id) return Boolean;
+ -- Determine whether arbitrary entity Id denotes Suspension_Object
+ -- defined in Ada.Synchronous_Task_Control.
- begin
- -- Do not attempt to load Ada.Synchronous_Task_Control in No_Run_Time
- -- mode. The unit contains tagged types and those are not allowed in
- -- this mode.
+ --------------------------
+ -- Is_Suspension_Object --
+ --------------------------
- if No_Run_Time_Mode then
- return False;
+ function Is_Suspension_Object (Id : Entity_Id) return Boolean is
+ begin
+ -- This approach does an exact name match rather than to rely on
+ -- RTSfind. Routine Is_Effectively_Volatile is used by clients of
+ -- the front end at point where all auxiliary tables are locked
+ -- and any modifications to them are treated as violations. Do not
+ -- tamper with the tables, instead examine the Chars fields of all
+ -- the scopes of Id.
- -- Unit Ada.Synchronous_Task_Control is not available, the type
- -- cannot possibly be a descendant of Suspension_Object.
+ return
+ Chars (Id) = Name_Suspension_Object
+ and then Present (Scope (Id))
+ and then Chars (Scope (Id)) = Name_Synchronous_Task_Control
+ and then Present (Scope (Scope (Id)))
+ and then Chars (Scope (Scope (Id))) = Name_Ada;
+ end Is_Suspension_Object;
- elsif not RTE_Available (RE_Suspension_Object) then
- return False;
- end if;
+ -- Local variables
+ Cur_Typ : Entity_Id;
+ Par_Typ : Entity_Id;
+
+ -- Start of processing for Is_Descendant_Of_Suspension_Object
+
+ begin
-- Climb the type derivation chain checking each parent type against
-- Suspension_Object.
@@ -11435,7 +11448,7 @@
-- The current type is a match
- if Is_RTE (Cur_Typ, RE_Suspension_Object) then
+ if Is_Suspension_Object (Cur_Typ) then
return True;
-- Stop the traversal once the root of the derivation chain has
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 229047)
+++ snames.ads-tmpl (working copy)
@@ -1398,6 +1398,8 @@
-- Other miscellaneous names used in front end
Name_Unaligned_Valid : constant Name_Id := N + $;
+ Name_Suspension_Object : constant Name_Id := N + $;
+ Name_Synchronous_Task_Control : constant Name_Id := N + $;
-- Names used to implement iterators over predefined containers
