From da566eeb31056d9f40ab48688dc3fe680535ce80 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Tue, 7 Jan 2020 22:57:19 -0500 Subject: [PATCH] [Ada] Incorrect accessibility checking on aliased formals 2020-06-03 Justin Squirek 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. --- 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 -- 2.30.2