public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc(refs/users/guojiufu/heads/personal-branch)] [Ada] Incorrect accessibility checking on aliased formals
@ 2020-06-10 3:29 Jiu Fu Guo
0 siblings, 0 replies; only message in thread
From: Jiu Fu Guo @ 2020-06-10 3:29 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:da566eeb31056d9f40ab48688dc3fe680535ce80
commit da566eeb31056d9f40ab48688dc3fe680535ce80
Author: Justin Squirek <squirek@adacore.com>
Date: Tue Jan 7 22:57:19 2020 -0500
[Ada] Incorrect accessibility checking on aliased formals
2020-06-03 Justin Squirek <squirek@adacore.com>
gcc/ada/
* libgnat/a-cborse.adb, libgnat/a-cihase.adb,
libgnat/a-ciorse.adb, libgnat/a-coorse.adb: Modified to use
'Unrestricted_Access in certain cases where static accessibility
errors were triggered.
* exp_ch6.adb (Expand_Simple_Return_Statement): Add generation
of dynamic accessibility checks as determined by
Is_Special_Aliased_Formal_Access.
* sem_attr.adb (Resolve_Attribute): Add call to
Is_Special_Aliased_Formal_Access to avoid performing static
checks where dynamic ones are required.
* sem_ch6.adb (Check_Return_Obj_Accessibility): Handle renamed
objects within component associations requiring special
accessibility checks.
* sem_util.adb, sem_util.ads (Is_Special_Aliased_Formal_Access):
Created to detect the special case where an aliased formal is
being compared against the level of an anonymous access return
object.
(Object_Access_Level): Remove incorrect condition leading to
overly permissive accessibility levels being returned on
explicitly aliased parameters.
Diff:
---
gcc/ada/exp_ch6.adb | 54 +++++++++++++++++++++++++------------------
gcc/ada/libgnat/a-cborse.adb | 4 ++--
gcc/ada/libgnat/a-cihase.adb | 4 ++--
gcc/ada/libgnat/a-ciorse.adb | 4 ++--
gcc/ada/libgnat/a-coorse.adb | 4 ++--
gcc/ada/sem_attr.adb | 12 +++++++++-
gcc/ada/sem_ch6.adb | 55 ++++++++++++++++++++++++++------------------
gcc/ada/sem_util.adb | 53 +++++++++++++++++++++++++++++++-----------
gcc/ada/sem_util.ads | 11 +++++++++
9 files changed, 134 insertions(+), 67 deletions(-)
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index cc9c6e3c15e..11980a6684c 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -6769,6 +6769,28 @@ package body Exp_Ch6 is
-- of the return object to the specific type on assignments to the
-- individual components.
+ procedure Check_Against_Result_Level (Level : Node_Id);
+ -- Check the given accessibility level against the level
+ -- determined by the point of call. (AI05-0234).
+
+ --------------------------------
+ -- Check_Against_Result_Level --
+ --------------------------------
+
+ procedure Check_Against_Result_Level (Level : Node_Id) is
+ begin
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Level,
+ Right_Opnd =>
+ New_Occurrence_Of
+ (Extra_Accessibility_Of_Result (Scope_Id), Loc)),
+ Reason => PE_Accessibility_Check_Failed));
+ end Check_Against_Result_Level;
+
+ -- Start of processing for Expand_Simple_Function_Return
begin
if Is_Class_Wide_Type (R_Type)
and then not Is_Class_Wide_Type (Exptyp)
@@ -7315,6 +7337,16 @@ package body Exp_Ch6 is
Suppress => All_Checks);
end if;
+ -- Determine if the special rules within RM 3.10.2 for explicitly
+ -- aliased formals apply to Exp - in which case we require a dynamic
+ -- check to be generated.
+
+ if Is_Special_Aliased_Formal_Access (Exp, Scope_Id) then
+ Check_Against_Result_Level
+ (Make_Integer_Literal (Loc,
+ Object_Access_Level (Entity (Ultimate_Prefix (Prefix (Exp))))));
+ end if;
+
-- AI05-0234: RM 6.5(21/3). Check access discriminants to
-- ensure that the function result does not outlive an
-- object designated by one of it discriminants.
@@ -7324,28 +7356,6 @@ package body Exp_Ch6 is
then
declare
Discrim_Source : Node_Id;
-
- procedure Check_Against_Result_Level (Level : Node_Id);
- -- Check the given accessibility level against the level
- -- determined by the point of call. (AI05-0234).
-
- --------------------------------
- -- Check_Against_Result_Level --
- --------------------------------
-
- procedure Check_Against_Result_Level (Level : Node_Id) is
- begin
- Insert_Action (N,
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => Level,
- Right_Opnd =>
- New_Occurrence_Of
- (Extra_Accessibility_Of_Result (Scope_Id), Loc)),
- Reason => PE_Accessibility_Check_Failed));
- end Check_Against_Result_Level;
-
begin
Discrim_Source := Exp;
while Nkind (Discrim_Source) = N_Qualified_Expression loop
diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb
index deca9b7efe6..649b6c1827d 100644
--- a/gcc/ada/libgnat/a-cborse.adb
+++ b/gcc/ada/libgnat/a-cborse.adb
@@ -933,7 +933,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is
Control =>
(Controlled with
Container.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Pos => Position,
Old_Key => new Key_Type'(Key (Position))))
do
@@ -961,7 +961,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is
Control =>
(Controlled with
Container.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Pos => Find (Container, Key),
Old_Key => new Key_Type'(Key)))
do
diff --git a/gcc/ada/libgnat/a-cihase.adb b/gcc/ada/libgnat/a-cihase.adb
index c9510278d26..1c5179936b9 100644
--- a/gcc/ada/libgnat/a-cihase.adb
+++ b/gcc/ada/libgnat/a-cihase.adb
@@ -2227,7 +2227,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Control =>
(Controlled with
HT.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Index => HT_Ops.Index (HT, Position.Node),
Old_Pos => Position,
Old_Hash => Hash (Key (Position))))
@@ -2261,7 +2261,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Control =>
(Controlled with
HT.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Index => HT_Ops.Index (HT, P.Node),
Old_Pos => P,
Old_Hash => Hash (Key)))
diff --git a/gcc/ada/libgnat/a-ciorse.adb b/gcc/ada/libgnat/a-ciorse.adb
index 69908089b28..349a59d69ac 100644
--- a/gcc/ada/libgnat/a-ciorse.adb
+++ b/gcc/ada/libgnat/a-ciorse.adb
@@ -1013,7 +1013,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Control =>
(Controlled with
Tree.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Pos => Position,
Old_Key => new Key_Type'(Key (Position))))
do
@@ -1045,7 +1045,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Control =>
(Controlled with
Tree.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Pos => Find (Container, Key),
Old_Key => new Key_Type'(Key)))
do
diff --git a/gcc/ada/libgnat/a-coorse.adb b/gcc/ada/libgnat/a-coorse.adb
index 156e4c67789..7291e0aa6d2 100644
--- a/gcc/ada/libgnat/a-coorse.adb
+++ b/gcc/ada/libgnat/a-coorse.adb
@@ -899,7 +899,7 @@ package body Ada.Containers.Ordered_Sets is
Control =>
(Controlled with
Tree.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Pos => Position,
Old_Key => new Key_Type'(Key (Position))))
do
@@ -927,7 +927,7 @@ package body Ada.Containers.Ordered_Sets is
Control =>
(Controlled with
Tree.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Pos => Find (Container, Key),
Old_Key => new Key_Type'(Key)))
do
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 79ba4c45ea0..07f01178786 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -10970,9 +10970,19 @@ package body Sem_Attr is
or else Nkind (Associated_Node_For_Itype (Btyp)) =
N_Object_Declaration)
+ and then Attr_Id = Attribute_Access
+
+ -- Verify that static checking is OK (namely that we aren't
+ -- in a specific context requiring dynamic checks on
+ -- expicitly aliased parameters), and then check the level.
+
+ -- Otherwise a check will be generated later when the return
+ -- statement gets expanded.
+
+ and then not Is_Special_Aliased_Formal_Access
+ (N, Current_Scope)
and then
Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
- and then Attr_Id = Attribute_Access
then
-- In an instance, this is a runtime check, but one we know
-- will fail, so generate an appropriate warning. As usual,
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 12a1ad79542..0b002eb5927 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -813,40 +813,51 @@ package body Sem_Ch6 is
then
-- Obtain the object to perform static checks on by moving
-- up the prefixes in the expression taking into account
- -- named access types.
+ -- named access types and renamed objects within the
+ -- expression.
Obj := Original_Node (Prefix (Expr));
- while Nkind_In (Obj, N_Explicit_Dereference,
- N_Indexed_Component,
- N_Selected_Component)
loop
- -- When we encounter a named access type then we can
- -- ignore accessibility checks on the dereference.
+ while Nkind_In (Obj, N_Explicit_Dereference,
+ N_Indexed_Component,
+ N_Selected_Component)
+ loop
+ -- When we encounter a named access type then we can
+ -- ignore accessibility checks on the dereference.
- if Ekind (Etype (Original_Node (Prefix (Obj))))
- in E_Access_Type ..
- E_Access_Protected_Subprogram_Type
- then
- if Nkind (Obj) = N_Selected_Component then
- Obj := Selector_Name (Obj);
- else
- Obj := Original_Node (Prefix (Obj));
+ if Ekind (Etype (Original_Node (Prefix (Obj))))
+ in E_Access_Type ..
+ E_Access_Protected_Subprogram_Type
+ then
+ if Nkind (Obj) = N_Selected_Component then
+ Obj := Selector_Name (Obj);
+ else
+ Obj := Original_Node (Prefix (Obj));
+ end if;
+ exit;
end if;
- exit;
+
+ Obj := Original_Node (Prefix (Obj));
+ end loop;
+
+ if Nkind (Obj) = N_Selected_Component then
+ Obj := Selector_Name (Obj);
end if;
- Obj := Original_Node (Prefix (Obj));
- end loop;
+ -- Check for renamings
- if Nkind (Obj) = N_Selected_Component then
- Obj := Selector_Name (Obj);
- end if;
+ pragma Assert (Is_Entity_Name (Obj));
+
+ if Present (Renamed_Object (Entity (Obj))) then
+ Obj := Renamed_Object (Entity (Obj));
+ else
+ exit;
+ end if;
+ end loop;
-- Do not check aliased formals or function calls. A
-- run-time check may still be needed ???
- pragma Assert (Is_Entity_Name (Obj));
-
if Is_Formal (Entity (Obj))
and then Is_Aliased (Entity (Obj))
then
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 6c197b517d5..09fcfb785ec 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -17885,6 +17885,44 @@ package body Sem_Util is
end if;
end Is_SPARK_05_Object_Reference;
+ --------------------------------------
+ -- Is_Special_Aliased_Formal_Access --
+ --------------------------------------
+
+ function Is_Special_Aliased_Formal_Access
+ (Exp : Node_Id;
+ Scop : Entity_Id) return Boolean is
+ begin
+ -- Verify the expression is an access reference to 'Access within a
+ -- return statement as this is the only time an explicitly aliased
+ -- formal has different semantics.
+
+ if Nkind (Exp) /= N_Attribute_Reference
+ or else Get_Attribute_Id (Attribute_Name (Exp)) /= Attribute_Access
+ or else Nkind (Parent (Exp)) /= N_Simple_Return_Statement
+ then
+ return False;
+ end if;
+
+ -- Check if the prefix of the reference is indeed an explicitly aliased
+ -- formal parameter for the function Scop. Additionally, we must check
+ -- that Scop returns an anonymous access type, otherwise the special
+ -- rules dictating a need for a dynamic check are not in effect.
+
+ declare
+ P_Ult : constant Node_Id := Ultimate_Prefix (Prefix (Exp));
+ begin
+ return Is_Entity_Name (P_Ult)
+ and then Is_Aliased (Entity (P_Ult))
+ and then Is_Formal (Entity (P_Ult))
+ and then Scope (Entity (P_Ult)) = Scop
+ and then Ekind_In (Scop, E_Function,
+ E_Operator,
+ E_Subprogram_Type)
+ and then Present (Extra_Accessibility_Of_Result (Scop));
+ end;
+ end Is_Special_Aliased_Formal_Access;
+
-----------------------------
-- Is_Specific_Tagged_Type --
-----------------------------
@@ -23099,20 +23137,7 @@ package body Sem_Util is
return Type_Access_Level (Scope (E)) + 1;
else
- -- Aliased formals of functions take their access level from the
- -- point of call, i.e. require a dynamic check. For static check
- -- purposes, this is smaller than the level of the subprogram
- -- itself. For procedures the aliased makes no difference.
-
- if Is_Formal (E)
- and then Is_Aliased (E)
- and then Ekind (Scope (E)) = E_Function
- then
- return Type_Access_Level (Etype (E));
-
- else
- return Scope_Depth (Enclosing_Dynamic_Scope (E));
- end if;
+ return Scope_Depth (Enclosing_Dynamic_Scope (E));
end if;
elsif Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 4d917448954..e6aa9e29a84 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1985,6 +1985,17 @@ package Sem_Util is
-- constants, formal parameters, and selected_components of those are
-- valid objects in SPARK 2005.
+ function Is_Special_Aliased_Formal_Access
+ (Exp : Node_Id;
+ Scop : Entity_Id) return Boolean;
+ -- Determines whether a dynamic check must be generated for explicitly
+ -- aliased formals within a function Scop for the expression Exp.
+
+ -- More specially, Is_Special_Aliased_Formal_Access checks that Exp is a
+ -- 'Access attribute reference within a return statement where the ultimate
+ -- prefix is an aliased formal of Scop and that Scop returns an anonymous
+ -- access type. See RM 3.10.2 for more details.
+
function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean;
-- Determine whether an arbitrary [private] type is specifically tagged
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2020-06-10 3:29 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2020-06-10 3:29 [gcc(refs/users/guojiufu/heads/personal-branch)] [Ada] Incorrect accessibility checking on aliased formals Jiu Fu Guo
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).