From f459afaa679956df1f3c0243a87583e4d4b43a2e Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Thu, 17 Nov 2022 15:34:57 +0000 Subject: ada: Accessibility code reorganization and bug fixes This patch performs a large reorganization of accessibility related sources, and also corrects some latent issues with accessibility checks - namely the calculation of accessibility levels for expanded iterators and type conversions. gcc/ada/ * accessibility.adb, accessibility.ads (Accessibility_Message): Moved from sem_attr. (Apply_Accessibility_Check): Moved from checks. (Apply_Accessibility_Check_For_Allocator): Moved from exp_ch4 and renamed (Check_Return_Construct_Accessibility): Moved from sem_ch6. (Innermost_Master_Scope_Depth): Moved from sem_util. Add condition to detect expanded iterators. (Prefix_With_Safe_Accessibility_Level): Moved from sem_attr. (Static_Accessibility_Level): Moved from sem_util. (Has_Unconstrained_Access_Discriminants): Likewise. (Has_Anonymous_Access_Discriminant): Likewise. (Is_Anonymous_Access_Actual): Likewise. (Is_Special_Aliased_Formal_Access): Likewise. (Needs_Result_Accessibility_Level): Likewise. (Subprogram_Access_Level): Likewise. (Type_Access_Level): Likewise. (Deepest_Type_Access_Level): Likewise. (Effective_Extra_Accessibility): Likewise. (Get_Dynamic_Accessibility): Likewise. (Has_Access_Values): Likewise. (Accessibility_Level): Likewise. * exp_attr.adb (Access_Cases): Obtain the proper enclosing object which applies to a given 'Access by looking through type conversions. * exp_ch4.adb (Apply_Accessibility_Check): Moved to accessibility. * exp_ch5.adb: Likewise. * exp_ch6.adb: Likewise. * exp_ch9.adb: Likewise. * exp_disp.adb: Likewise. * gen_il-fields.ads: Add new flag Comes_From_Iterator. * gen_il-gen-gen_nodes.adb: Add new flag Comes_From_Iterator for N_Object_Renaming_Declaration. * sem_ch5.adb (Analyze_Iterator_Specification): Mark object renamings resulting from iterator expansion with the new flag Comes_From_Iterator. * sem_aggr.adb (Resolve_Container_Aggregate): Refine test. * sem_ch13.adb: Add dependence on the accessibility package. * sem_ch3.adb: Likewise. * sem_ch4.adb: Likewise. * sem_ch9.adb: Likewise. * sem_res.adb: Likewise. * sem_warn.adb: Likewise. * exp_ch3.adb: Likewise. * sem_attr.adb (Accessibility_Message): Moved to accessibility. (Prefix_With_Safe_Accessibility_Level): Likewise. * checks.adb, checks.ads (Apply_Accessibility_Check): Likewise. * sem_ch6.adb (Check_Return_Construct_Accessibility): Likewise. * sem_util.adb, sem_util.ads (Accessibility_Level): Likewise. (Deepest_Type_Access_Level): Likewise. (Effective_Extra_Accessibility): Likewise. (Get_Dynamic_Accessibility): Likewise. (Has_Access_Values): Likewise. (Has_Anonymous_Access_Discriminant): Likewise. (Static_Accessibility_Level): Likewise. (Has_Unconstrained_Access_Discriminants): Likewise. (Is_Anonymous_Access_Actual): Likewise. (Is_Special_Aliased_Formal_Access): Likewise. (Needs_Result_Accessibility_Level): Likewise. (Subprogram_Access_Level): Likewise. (Type_Access_Level): Likewise. * sinfo.ads: Document new flag Comes_From_Iterator. * gcc-interface/Make-lang.in: Add entry for new Accessibility package. --- gcc/ada/sem_attr.adb | 133 ++------------------------------------------------- 1 file changed, 5 insertions(+), 128 deletions(-) (limited to 'gcc/ada/sem_attr.adb') diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index cca6f6f..7c76f0f 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -25,6 +25,7 @@ with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Casing; use Casing; @@ -10936,72 +10937,12 @@ package body Sem_Attr is It : Interp; Nom_Subt : Entity_Id; - procedure Accessibility_Message; - -- Error, or warning within an instance, if the static accessibility - -- rules of 3.10.2 are violated. - function Declared_Within_Generic_Unit (Entity : Entity_Id; Generic_Unit : Node_Id) return Boolean; -- Returns True if Declared_Entity is declared within the declarative -- region of Generic_Unit; otherwise returns False. - function Prefix_With_Safe_Accessibility_Level return Boolean; - -- Return True if the prefix does not have a value conversion of an - -- array because a value conversion is like an aggregate with respect - -- to determining accessibility level (RM 3.10.2); even if evaluation - -- of a value conversion is guaranteed to not create a new object, - -- accessibility rules are defined as if it might. - - --------------------------- - -- Accessibility_Message -- - --------------------------- - - procedure Accessibility_Message is - Indic : Node_Id := Parent (Parent (N)); - - begin - -- In an instance, this is a runtime check, but one we - -- know will fail, so generate an appropriate warning. - - if In_Instance_Body then - Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_F - ("non-local pointer cannot point to local object<<", P); - Error_Msg_F ("\Program_Error [<<", P); - Rewrite (N, - Make_Raise_Program_Error (Loc, - Reason => PE_Accessibility_Check_Failed)); - Set_Etype (N, Typ); - return; - - else - Error_Msg_F ("non-local pointer cannot point to local object", P); - - -- Check for case where we have a missing access definition - - if Is_Record_Type (Current_Scope) - and then - Nkind (Parent (N)) in N_Discriminant_Association - | N_Index_Or_Discriminant_Constraint - then - Indic := Parent (Parent (N)); - while Present (Indic) - and then Nkind (Indic) /= N_Subtype_Indication - loop - Indic := Parent (Indic); - end loop; - - if Present (Indic) then - Error_Msg_NE - ("\use an access definition for" & - " the access discriminant of&", - N, Entity (Subtype_Mark (Indic))); - end if; - end if; - end if; - end Accessibility_Message; - ---------------------------------- -- Declared_Within_Generic_Unit -- ---------------------------------- @@ -11029,70 +10970,6 @@ package body Sem_Attr is return False; end Declared_Within_Generic_Unit; - ------------------------------------------ - -- Prefix_With_Safe_Accessibility_Level -- - ------------------------------------------ - - function Prefix_With_Safe_Accessibility_Level return Boolean is - function Safe_Value_Conversions return Boolean; - -- Return False if the prefix has a value conversion of an array type - - ---------------------------- - -- Safe_Value_Conversions -- - ---------------------------- - - function Safe_Value_Conversions return Boolean is - PP : Node_Id := P; - - begin - loop - if Nkind (PP) in N_Selected_Component | N_Indexed_Component then - PP := Prefix (PP); - - elsif Comes_From_Source (PP) - and then Nkind (PP) in N_Type_Conversion - | N_Unchecked_Type_Conversion - and then Is_Array_Type (Etype (PP)) - then - return False; - - elsif Comes_From_Source (PP) - and then Nkind (PP) = N_Qualified_Expression - and then Is_Array_Type (Etype (PP)) - and then Nkind (Original_Node (Expression (PP))) in - N_Aggregate | N_Extension_Aggregate - then - return False; - - else - exit; - end if; - end loop; - - return True; - end Safe_Value_Conversions; - - -- Start of processing for Prefix_With_Safe_Accessibility_Level - - begin - -- No check required for unchecked and unrestricted access - - if Attr_Id = Attribute_Unchecked_Access - or else Attr_Id = Attribute_Unrestricted_Access - then - return True; - - -- Check value conversions - - elsif Ekind (Btyp) = E_General_Access_Type - and then not Safe_Value_Conversions - then - return False; - end if; - - return True; - end Prefix_With_Safe_Accessibility_Level; - -- Start of processing for Resolve_Attribute begin @@ -11778,7 +11655,7 @@ package body Sem_Attr is Intval (Accessibility_Level (P, Dynamic_Level)) > Deepest_Type_Access_Level (Btyp) then - Accessibility_Message; + Accessibility_Message (N, Typ); return; end if; end; @@ -11804,7 +11681,7 @@ package body Sem_Attr is and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type and then Attr_Id /= Attribute_Unrestricted_Access then - Accessibility_Message; + Accessibility_Message (N, Typ); return; -- AI05-0225: If the context is not an access to protected @@ -11963,8 +11840,8 @@ package body Sem_Attr is -- array type since a value conversion is like an aggregate with -- respect to determining accessibility level (RM 3.10.2). - if not Prefix_With_Safe_Accessibility_Level then - Accessibility_Message; + if not Prefix_With_Safe_Accessibility_Level (N, Typ) then + Accessibility_Message (N, Typ); return; end if; -- cgit v1.1