From: Eric Botcazou <[email protected]>
The checks are those prescribed by the RM 13.11.4(24-27) rules, which are
part of dynamic semantics but can be applied statically for the most part.
While the current implementation is incomplete, the fix is straightforward
and mostly boils down to redoing the associated static accessibility checks
of RM 13.11.4(22-23) without too much duplication in the implementation.
gcc/ada/ChangeLog:
* sem_util.ads (Get_Pool_Object_Or_Dereference): New function.
* sem_util.adb (Get_Pool_Object_Or_Dereference): Likewise, mostly
taken from...
* sem_ch13.adb (Analyze_Attribute_Definition_Clause) <Object_From>:
...here.
<Attribute_Storage_Pool>: Call Get_Pool_Object_Or_Dereference.
* exp_ch3.adb (Freeze_Type): Add missing checks of RM 13.11.4(24-27)
and apply them to all regular pools not statically descendants from
Root_Storage_Pool_With_Subpools when its unit has been loaded.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch3.adb | 72 ++++++++++++++++++++++++++++++++------------
gcc/ada/sem_ch13.adb | 62 ++++++++------------------------------
gcc/ada/sem_util.adb | 38 +++++++++++++++++++++++
gcc/ada/sem_util.ads | 5 +++
4 files changed, 107 insertions(+), 70 deletions(-)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index b67e784c6c4..96374dcdb12 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -10014,34 +10014,63 @@ package body Exp_Ch3 is
-- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
-- ---> Storage Pool is the specified one
- -- When compiling in Ada 2012 mode, ensure that the accessibility
- -- level of the subpool access type is not deeper than that of the
- -- pool_with_subpools.
+ -- When compiling in Ada 2012 mode, apply the RM 13.11.4(24-27)
+ -- rules, which are dynamic but can be applied statically for
+ -- the most part, and therefore are only concerned with pools
+ -- that have escaped the RM 13.11.4(22-23) legality checks and
+ -- thus are not descendants of Root_Storage_Pool_With_Subpools,
+ -- but may nevertheless have a tag that identifies them as such.
elsif Ada_Version >= Ada_2012
+ and then not Accessibility_Checks_Suppressed (Def_Id)
and then Present (Associated_Storage_Pool (Def_Id))
+ and then not
+ Is_RTE (Associated_Storage_Pool (Def_Id), RE_RS_Pool)
+ and then not
+ Is_RTE (Associated_Storage_Pool (Def_Id), RE_SS_Pool)
+ and then not
+ Accessibility_Checks_Suppressed
+ (Associated_Storage_Pool (Def_Id))
and then RTU_Loaded (System_Storage_Pools_Subpools)
+ and then not
+ Is_Ancestor (RTE (RE_Root_Storage_Pool_With_Subpools),
+ Etype (Associated_Storage_Pool (Def_Id)))
then
declare
- Loc : constant Source_Ptr := Sloc (Def_Id);
- Pool : constant Entity_Id :=
- Associated_Storage_Pool (Def_Id);
+ ADC : constant Node_Id :=
+ Get_Attribute_Definition_Clause
+ (Def_Id, Attribute_Storage_Pool);
+ Loc : constant Source_Ptr := Sloc (ADC);
+ Pool : constant Entity_Id :=
+ Associated_Storage_Pool (Def_Id);
+ Base : constant Node_Or_Entity_Id :=
+ Get_Pool_Object_Or_Dereference (Pool);
+
+ Is_Part_Of_Formal : constant Boolean :=
+ Present (Base)
+ and then Nkind (Base) = N_Defining_Identifier
+ and then Is_Formal (Base);
+ -- Whether the pool denotes part of a formal parameter
+
+ Is_Part_Of_Dereference : constant Boolean :=
+ Present (Base)
+ and then Nkind (Base) = N_Explicit_Dereference
+ and then
+ Ekind (Etype (Prefix (Base))) = E_General_Access_Type
+ and then not
+ Is_Library_Level_Entity (Etype (Prefix (Base)));
+ -- Whether the pool denotes part of a dereference of a
+ -- value of a non-library-level general access type.
begin
- -- It is known that the accessibility level of the access
- -- type is deeper than that of the pool.
-
- if Type_Access_Level (Def_Id)
- > Static_Accessibility_Level (Pool, Object_Decl_Level)
- and then Is_Class_Wide_Type (Etype (Pool))
- and then not Accessibility_Checks_Suppressed (Def_Id)
- and then not Accessibility_Checks_Suppressed (Pool)
+ if Is_Part_Of_Formal
+ or else Is_Part_Of_Dereference
+ or else
+ Type_Access_Level (Def_Id)
+ > Static_Accessibility_Level (Pool, Object_Decl_Level)
then
- -- When the pool is of a class-wide type, it may or may
- -- not support subpools depending on the path of
- -- derivation. Generate:
-
- -- if Def_Id in RSPWS'Class then
+ -- Generate:
+ -- if RSP'Class?(Def_Id) in RSPWS'Class then
-- raise Program_Error;
-- end if;
@@ -10049,7 +10078,10 @@ package body Exp_Ch3 is
Make_If_Statement (Loc,
Condition =>
Make_In (Loc,
- Left_Opnd => New_Occurrence_Of (Pool, Loc),
+ Left_Opnd =>
+ OK_Convert_To
+ (Class_Wide_Type (RTE (RE_Root_Storage_Pool)),
+ New_Occurrence_Of (Pool, Loc)),
Right_Opnd =>
New_Occurrence_Of
(Class_Wide_Type
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 397285d3df1..10531886508 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -8055,51 +8055,7 @@ package body Sem_Ch13 is
procedure Associate_Storage_Pool
(Ent : Entity_Id; Pool : Entity_Id)
is
- function Object_From (Pool : Entity_Id) return Entity_Id;
- -- Return the entity of which Pool is a part of
-
- -----------------
- -- Object_From --
- -----------------
-
- function Object_From
- (Pool : Entity_Id) return Entity_Id
- is
- N : Node_Id := Pool;
- begin
- if Present (Renamed_Object (Pool)) then
- N := Renamed_Object (Pool);
- end if;
-
- while Present (N) loop
- case Nkind (N) is
- when N_Defining_Identifier =>
- return N;
-
- when N_Identifier | N_Expanded_Name =>
- return Entity (N);
-
- when N_Indexed_Component | N_Selected_Component |
- N_Explicit_Dereference
- =>
- N := Prefix (N);
-
- when N_Type_Conversion =>
- N := Expression (N);
-
- when others =>
- -- ??? we probably should handle more cases but
- -- this is good enough in practice for this check
- -- on a corner case.
-
- return Empty;
- end case;
- end loop;
-
- return Empty;
- end Object_From;
-
- Obj : Entity_Id;
+ Base : Node_Or_Entity_Id;
begin
Set_Associated_Storage_Pool (Ent, Pool);
@@ -8138,11 +8094,14 @@ package body Sem_Ch13 is
return;
end if;
- Obj := Object_From (Pool);
+ Base := Get_Pool_Object_Or_Dereference (Pool);
-- check (C)
- if Present (Obj) and then Is_Formal (Obj) then
+ if Present (Base)
+ and then Nkind (Base) = N_Defining_Identifier
+ and then Is_Formal (Base)
+ then
Error_Msg_N
("subpool cannot be part of a parameter", Ent);
return;
@@ -8150,9 +8109,12 @@ package body Sem_Ch13 is
-- check (D)
- if Present (Obj)
- and then Ekind (Etype (Obj)) = E_General_Access_Type
- and then not Is_Library_Level_Entity (Etype (Obj))
+ if Present (Base)
+ and then Nkind (Base) = N_Explicit_Dereference
+ and then
+ Ekind (Etype (Prefix (Base))) = E_General_Access_Type
+ and then not
+ Is_Library_Level_Entity (Etype (Prefix (Base)))
then
Error_Msg_N
("subpool cannot be part of the dereference of a " &
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 87fec5394be..943dbc269c6 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -10597,6 +10597,44 @@ package body Sem_Util is
end if;
end Get_Enclosing_Object;
+ ------------------------------------
+ -- Get_Pool_Object_Or_Dereference --
+ ------------------------------------
+
+ function Get_Pool_Object_Or_Dereference (Pool : Entity_Id)
+ return Node_Or_Entity_Id
+ is
+ N : Node_Or_Entity_Id;
+
+ begin
+ if Present (Renamed_Object (Pool)) then
+ N := Renamed_Object (Pool);
+ else
+ N := Pool;
+ end if;
+
+ while Present (N) loop
+ case Nkind (N) is
+ when N_Defining_Identifier | N_Explicit_Dereference =>
+ return N;
+
+ when N_Identifier | N_Expanded_Name =>
+ return Entity (N);
+
+ when N_Indexed_Component | N_Selected_Component | N_Slice =>
+ N := Prefix (N);
+
+ when N_Type_Conversion | N_Unchecked_Type_Conversion =>
+ N := Expression (N);
+
+ when others =>
+ exit;
+ end case;
+ end loop;
+
+ return Empty;
+ end Get_Pool_Object_Or_Dereference;
+
---------------------------
-- Get_Enum_Lit_From_Pos --
---------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 46987bcc469..2df0f327e0f 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1295,6 +1295,11 @@ package Sem_Util is
-- has not yet been rewritten as a package declaration, and the entity has
-- to be retrieved from the Instance_Spec of the unit.
+ function Get_Pool_Object_Or_Dereference (Pool : Entity_Id)
+ return Node_Or_Entity_Id;
+ -- Return the entity or dereference of which Pool is a part, if it exists.
+ -- Otherwise return Empty.
+
function Get_Pragma_Id (N : Node_Id) return Pragma_Id;
pragma Inline (Get_Pragma_Id);
-- Obtains the Pragma_Id from Pragma_Name_Unmapped (N)
--
2.53.0
