From: Justin Squirek Date: Mon, 29 Mar 2021 12:46:02 +0000 (-0400) Subject: [Ada] INOX: prototype alternative accessibility model X-Git-Tag: basepoints/gcc-13~6292 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=bcb8c3bba756feb252340757e0944956684b7cfb;p=thirdparty%2Fgcc.git [Ada] INOX: prototype alternative accessibility model gcc/ada/ * checks.adb (Accessibility_Checks_Suppressed): Add check against restriction No_Dynamic_Accessibility_Checks. (Apply_Accessibility_Check): Add assertion to check restriction No_Dynamic_Accessibility_Checks is not active. * debug.adb: Add documentation for new debugging switch to control which accessibility model gets employed under restriction No_Dynamic_Accessibility_Checks. * exp_attr.adb (Expand_N_Attribute_Reference): Disable dynamic accessibility check generation when No_Dynamic_Accessibility_Checks is active. * exp_ch4.adb (Apply_Accessibility_Check): Skip check generation when restriction No_Dynamic_Accessibility_Checks is active. (Expand_N_Allocator): Disable dynamic accessibility checks when No_Dynamic_Accessibility_Checks is active. (Expand_N_In): Disable dynamic accessibility checks when No_Dynamic_Accessibility_Checks is active. (Expand_N_Type_Conversion): Disable dynamic accessibility checks when No_Dynamic_Accessibility_Checks is active. * exp_ch5.adb (Expand_N_Assignment_Statement): Disable alternative accessibility model calculations when computing a dynamic level for a SAOAAT. * exp_ch6.adb (Add_Call_By_Copy_Code): Disable dynamic accessibility check generation when No_Dynamic_Accessibility_Checks is active. (Expand_Branch): Disable alternative accessibility model calculations. (Expand_Call_Helper): Disable alternative accessibility model calculations. * restrict.adb, restrict.ads: Add new restriction No_Dynamic_Accessibility_Checks. (No_Dynamic_Accessibility_Checks_Enabled): Created to test when experimental features (which are generally incompatible with standard Ada) can be enabled. * sem_attr.adb (Safe_Value_Conversions): Add handling of new accessibility model under the restriction No_Dynamic_Accessibility_Checks. * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings): Disallow new restriction No_Dynamic_Accessibility_Checks from being exclusively specified within a body or subunit without being present in a specification. * sem_res.adb (Check_Fully_Declared_Prefix): Minor comment fixup. (Valid_Conversion): Omit implicit conversion checks on anonymous access types and perform static checking instead when No_Dynamic_Accessibility_Checks is active. * sem_util.adb, sem_util.ads (Accessibility_Level): Add special handling of anonymous access objects, formal parameters, anonymous access components, and function return objects. (Deepest_Type_Access_Level): When No_Dynamic_Accessibility_Checks is active employ an alternative model. Add paramter Allow_Alt_Model to override the new behavior in certain cases. (Type_Access_Level): When No_Dynamic_Accessibility_Checks is active employ an alternative model. Add parameter Allow_Alt_Model to override the new behavior in certain cases. (Typ_Access_Level): Created within Accessibility_Level for convenience. * libgnat/s-rident.ads, snames.ads-tmpl: Add handing for No_Dynamic_Accessibility_Checks. --- diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 6c49e671e919..96a2a3f3df1d 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -379,8 +379,12 @@ package body Checks is function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is begin - if Present (E) and then Checks_May_Be_Suppressed (E) then + if No_Dynamic_Accessibility_Checks_Enabled (E) then + return True; + + elsif Present (E) and then Checks_May_Be_Suppressed (E) then return Is_Check_Suppressed (E, Accessibility_Check); + else return Scope_Suppress.Suppress (Accessibility_Check); end if; @@ -582,6 +586,11 @@ package body Checks is Type_Level : Node_Id; begin + -- Verify we haven't tried to add a dynamic accessibility check when we + -- shouldn't. + + pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N)); + if Ada_Version >= Ada_2012 and then not Present (Param_Ent) and then Is_Entity_Name (N) diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 978f333e9cc1..5a4d1d3cdaaf 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -140,7 +140,7 @@ package body Debug is -- d.Z Do not enable expansion in configurable run-time mode -- d_a Stop elaboration checks on accept or select statement - -- d_b + -- d_b Use compatibility model under No_Dynamic_Accessibility_Checks -- d_c CUDA compilation : compile for the host -- d_d -- d_e Ignore entry calls and requeue statements for elaboration diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index af7f205d50ce..067e7ede7046 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2366,6 +2366,7 @@ package body Exp_Attr is = E_Anonymous_Access_Type and then Present (Extra_Accessibility (Entity (Prefix (Enc_Object)))) + and then not No_Dynamic_Accessibility_Checks_Enabled (Enc_Object) then Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 54e91b2f2e38..d608a30a6912 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -615,6 +615,7 @@ package body Exp_Ch4 is and then Is_Class_Wide_Type (DesigT) and then Tagged_Type_Expansion and then not Scope_Suppress.Suppress (Accessibility_Check) + and then not No_Dynamic_Accessibility_Checks_Enabled (Ref) and then (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT) or else @@ -5277,6 +5278,8 @@ package body Exp_Ch4 is if Ada_Version >= Ada_2005 and then Ekind (Etype (Nod)) = E_Anonymous_Access_Type + and then not + No_Dynamic_Accessibility_Checks_Enabled (Nod) then Apply_Accessibility_Check (Nod, Typ, Insert_Node => Nod); @@ -6865,6 +6868,7 @@ package body Exp_Ch4 is if Ada_Version >= Ada_2012 and then Is_Acc and then Ekind (Ltyp) = E_Anonymous_Access_Type + and then not No_Dynamic_Accessibility_Checks_Enabled (Lop) then declare Expr_Entity : Entity_Id := Empty; @@ -12333,6 +12337,7 @@ package body Exp_Ch4 is and then Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type and then (Nkind (Original_Node (N)) /= N_Attribute_Reference or else Attribute_Name (Original_Node (N)) = Name_Access) + and then not No_Dynamic_Accessibility_Checks_Enabled (N) then if not Comes_From_Source (N) and then Nkind (Parent (N)) in N_Function_Call diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 4eba6fb4208b..2cc8b64f083b 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2771,7 +2771,9 @@ package body Exp_Ch5 is (Entity (Lhs)), Loc), Expression => Accessibility_Level - (Rhs, Dynamic_Level)); + (Expr => Rhs, + Level => Dynamic_Level, + Allow_Alt_Model => False)); begin if not Accessibility_Checks_Suppressed (Entity (Lhs)) then diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 3542411f4009..80ed21b59724 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1803,6 +1803,7 @@ package body Exp_Ch6 is and then Is_Entity_Name (Lhs) and then Present (Effective_Extra_Accessibility (Entity (Lhs))) + and then not No_Dynamic_Accessibility_Checks_Enabled (Lhs) then -- Copyback target is an Ada 2012 stand-alone object of an -- anonymous access type. @@ -2929,7 +2930,9 @@ package body Exp_Ch6 is Name => New_Occurrence_Of (Lvl, Loc), Expression => Accessibility_Level - (Expression (Res_Assn), Dynamic_Level))); + (Expr => Expression (Res_Assn), + Level => Dynamic_Level, + Allow_Alt_Model => False))); end if; end Expand_Branch; @@ -3857,9 +3860,10 @@ package body Exp_Ch6 is end if; Add_Extra_Actual - (Expr => - New_Occurrence_Of - (Get_Dynamic_Accessibility (Parm_Ent), Loc), + (Expr => Accessibility_Level + (Expr => Parm_Ent, + Level => Dynamic_Level, + Allow_Alt_Model => False), EF => Extra_Accessibility (Formal)); end; @@ -3890,15 +3894,20 @@ package body Exp_Ch6 is Add_Extra_Actual (Expr => Accessibility_Level - (Expr => Expression (Parent (Entity (Prev))), - Level => Dynamic_Level), + (Expr => Expression + (Parent (Entity (Prev))), + Level => Dynamic_Level, + Allow_Alt_Model => False), EF => Extra_Accessibility (Formal)); -- Normal case else Add_Extra_Actual - (Expr => Accessibility_Level (Prev, Dynamic_Level), + (Expr => Accessibility_Level + (Expr => Prev, + Level => Dynamic_Level, + Allow_Alt_Model => False), EF => Extra_Accessibility (Formal)); end if; end if; @@ -4142,8 +4151,10 @@ package body Exp_Ch6 is -- Otherwise get the level normally based on the call node else - Level := Accessibility_Level (Call_Node, Dynamic_Level); - + Level := Accessibility_Level + (Expr => Call_Node, + Level => Dynamic_Level, + Allow_Alt_Model => False); end if; -- It may be possible that we are re-expanding an already diff --git a/gcc/ada/libgnat/s-rident.ads b/gcc/ada/libgnat/s-rident.ads index 7d0a384b20ea..10d374ee5395 100644 --- a/gcc/ada/libgnat/s-rident.ads +++ b/gcc/ada/libgnat/s-rident.ads @@ -103,6 +103,7 @@ package System.Rident is No_Direct_Boolean_Operators, -- GNAT No_Dispatch, -- (RM H.4(19)) No_Dispatching_Calls, -- GNAT + No_Dynamic_Accessibility_Checks, -- GNAT No_Dynamic_Attachment, -- Ada 2012 (RM E.7(10/3)) No_Dynamic_CPU_Assignment, -- Ada 202x (RM D.7(10/3)) No_Dynamic_Priorities, -- (RM D.9(9)) diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 35922307460e..4f1dea4adef1 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -924,6 +924,21 @@ package body Restrict is or else Targparm.Restrictions_On_Target.Set (No_Tasking); end Global_No_Tasking; + --------------------------------------------- + -- No_Dynamic_Accessibility_Checks_Enabled -- + --------------------------------------------- + + function No_Dynamic_Accessibility_Checks_Enabled + (N : Node_Id) return Boolean + is + pragma Unreferenced (N); + -- N is currently unreferenced but present for debugging purposes and + -- potential future use. + + begin + return Restrictions.Set (No_Dynamic_Accessibility_Checks); + end No_Dynamic_Accessibility_Checks_Enabled; + ------------------------------- -- No_Exception_Handlers_Set -- ------------------------------- diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 806195e3d0f7..eec85c21283e 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -114,6 +114,7 @@ package Restrict is No_Default_Initialization => True, No_Direct_Boolean_Operators => True, No_Dispatching_Calls => True, + No_Dynamic_Accessibility_Checks => True, No_Dynamic_Attachment => True, No_Elaboration_Code => True, No_Enumeration_Maps => True, @@ -377,6 +378,15 @@ package Restrict is -- pragma Restrictions_Warning, or attribute Restriction_Set. Returns -- True if N has the proper form for an entity name, False otherwise. + function No_Dynamic_Accessibility_Checks_Enabled + (N : Node_Id) return Boolean; + -- Test to see if the current restrictions settings specify that + -- No_Dynamic_Accessibility_Checks is activated. + + -- N is currently unused, but is reserved for future use and debugging + -- purposes to provide more context on a node for which an accessibility + -- check is being performed or generated (e.g. is N in a predefined unit). + function No_Exception_Handlers_Set return Boolean; -- Test to see if current restrictions settings specify that no exception -- handlers are present. This function is called by Gigi when it needs to diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index b7297e5edfd1..e0b2072307fc 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -11290,7 +11290,11 @@ package body Sem_Attr is -- this kind of warning is an error in SPARK mode. if In_Instance_Body then - Error_Msg_Warn := SPARK_Mode /= On; + Error_Msg_Warn := + SPARK_Mode /= On + and then + not No_Dynamic_Accessibility_Checks_Enabled (P); + Error_Msg_F ("non-local pointer cannot point to local object<<", P); Error_Msg_F ("\Program_Error [<<", P); @@ -11422,10 +11426,13 @@ package body Sem_Attr is -- Check the static accessibility rule of 3.10.2(28). Note that -- this check is not performed for the case of an anonymous -- access type, since the access attribute is always legal - -- in such a context. + -- in such a context - unless the restriction + -- No_Dynamic_Accessibility_Checks is active. if Attr_Id /= Attribute_Unchecked_Access - and then Ekind (Btyp) = E_General_Access_Type + and then + (Ekind (Btyp) = E_General_Access_Type + or else No_Dynamic_Accessibility_Checks_Enabled (Btyp)) -- Call Accessibility_Level directly to avoid returning zero -- on cases where the prefix is an explicitly aliased diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 36b305eec31f..fa63fdae7300 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -10483,6 +10483,41 @@ package body Sem_Prag is Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); end if; + -- Special processing for No_Dynamic_Accessibility_Checks to + -- disallow exclusive specification in a body or subunit. + + elsif R_Id = No_Dynamic_Accessibility_Checks + -- Check if the restriction is within configuration pragma + -- in a similar way to No_Elaboration_Code. + + and then not (Current_Sem_Unit = Main_Unit + or else In_Extended_Main_Source_Unit (N)) + + and then Nkind (Unit (Parent (N))) = N_Compilation_Unit + + and then (Nkind (Unit (Parent (N))) = N_Package_Body + or else Nkind (Unit (Parent (N))) = N_Subunit) + + and then not Restriction_Active + (No_Dynamic_Accessibility_Checks) + then + Error_Msg_N + ("invalid specification of " & + """No_Dynamic_Accessibility_Checks""", N); + + if Nkind (Unit (Parent (N))) = N_Package_Body then + Error_Msg_N + ("\restriction cannot be specified in a package " & + "body", N); + + elsif Nkind (Unit (Parent (N))) = N_Subunit then + Error_Msg_N + ("\restriction cannot be specified in a subunit", N); + end if; + + Error_Msg_N + ("\unless also specified in spec", N); + -- Special processing for No_Tasking restriction (not just a -- warning) when it appears as a configuration pragma. diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b6a9b1d653c4..fb40484f2a63 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -654,9 +654,9 @@ package body Sem_Res is end if; end Check_For_Visible_Operator; - ---------------------------------- - -- Check_Fully_Declared_Prefix -- - ---------------------------------- + --------------------------------- + -- Check_Fully_Declared_Prefix -- + --------------------------------- procedure Check_Fully_Declared_Prefix (Typ : Entity_Id; @@ -13676,12 +13676,24 @@ package body Sem_Res is then if Is_Itype (Opnd_Type) then + -- When applying restriction No_Dynamic_Accessibility_Check, + -- implicit conversions are allowed when the operand type is + -- not deeper than the target type. + + if No_Dynamic_Accessibility_Checks_Enabled (N) then + if Type_Access_Level (Opnd_Type) + > Deepest_Type_Access_Level (Target_Type) + then + Conversion_Error_N + ("operand has deeper level than target", Operand); + end if; + -- Implicit conversions aren't allowed for objects of an -- anonymous access type, since such objects have nonstatic -- levels in Ada 2012. - if Nkind (Associated_Node_For_Itype (Opnd_Type)) = - N_Object_Declaration + elsif Nkind (Associated_Node_For_Itype (Opnd_Type)) + = N_Object_Declaration then Conversion_Error_N ("implicit conversion of stand-alone anonymous " diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b7d84afd69d5..e0a12bddca12 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -177,9 +177,9 @@ package body Sem_Util is -- "subp:file:line:col", corresponding to the source location of the -- body of the subprogram. - ------------------------------ - -- Abstract_Interface_List -- - ------------------------------ + ----------------------------- + -- Abstract_Interface_List -- + ----------------------------- function Abstract_Interface_List (Typ : Entity_Id) return List_Id is Nod : Node_Id; @@ -260,7 +260,8 @@ package body Sem_Util is function Accessibility_Level (Expr : Node_Id; Level : Accessibility_Level_Kind; - In_Return_Context : Boolean := False) return Node_Id + In_Return_Context : Boolean := False; + Allow_Alt_Model : Boolean := True) return Node_Id is Loc : constant Source_Ptr := Sloc (Expr); @@ -281,6 +282,11 @@ package body Sem_Util is -- Centralized processing of subprogram calls which may appear in -- prefix notation. + function Typ_Access_Level (Typ : Entity_Id) return Uint + is (Type_Access_Level (Typ, Allow_Alt_Model)); + -- Renaming of Type_Access_Level with Allow_Alt_Model specified to avoid + -- passing the parameter specifically in every call. + ---------------------------------- -- Innermost_Master_Scope_Depth -- ---------------------------------- @@ -375,7 +381,7 @@ package body Sem_Util is (Subprogram_Access_Level (Entity (Name (N)))); else return Make_Level_Literal - (Type_Access_Level (Etype (Prefix (Name (N))))); + (Typ_Access_Level (Etype (Prefix (Name (N))))); end if; -- We ignore coextensions as they cannot be implemented under the @@ -392,19 +398,39 @@ package body Sem_Util is -- Named access types have a designated level if Is_Named_Access_Type (Etype (N)) then - return Make_Level_Literal (Type_Access_Level (Etype (N))); + return Make_Level_Literal (Typ_Access_Level (Etype (N))); -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3) else + -- Check No_Dynamic_Accessibility_Checks restriction override for + -- alternative accessibility model. + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (N) + and then Is_Anonymous_Access_Type (Etype (N)) + then + -- In the alternative model the level is that of the subprogram + + if Debug_Flag_Underscore_B then + return Make_Level_Literal + (Subprogram_Access_Level (Current_Subprogram)); + end if; + + -- Otherwise the level is that of the designated type + + return Make_Level_Literal + (Typ_Access_Level (Etype (N))); + end if; + if Nkind (N) = N_Function_Call then -- Dynamic checks are generated when we are within a return -- value or we are in a function call within an anonymous -- access discriminant constraint of a return object (signified -- by In_Return_Context) on the side of the callee. - -- So, in this case, return library accessibility level to null - -- out the check on the side of the caller. + -- So, in this case, return accessibility level of the + -- enclosing subprogram. if In_Return_Value (N) or else In_Return_Context @@ -414,6 +440,17 @@ package body Sem_Util is end if; end if; + -- When the call is being dereferenced the level is that of the + -- enclosing master of the dereferenced call. + + if Nkind (Parent (N)) in N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component + then + return Make_Level_Literal + (Innermost_Master_Scope_Depth (Expr)); + end if; + -- Find any relevant enclosing parent nodes that designate an -- object being initialized. @@ -434,7 +471,7 @@ package body Sem_Util is and then Is_Named_Access_Type (Etype (Par)) then return Make_Level_Literal - (Type_Access_Level (Etype (Par))); + (Typ_Access_Level (Etype (Par))); end if; -- Jump out when we hit an object declaration or the right-hand @@ -551,7 +588,7 @@ package body Sem_Util is if Is_Named_Access_Type (Etype (Pre)) then return Make_Level_Literal - (Type_Access_Level (Etype (Pre))); + (Typ_Access_Level (Etype (Pre))); -- Anonymous access types @@ -616,8 +653,36 @@ package body Sem_Util is (Scope_Depth (Standard_Standard)); end if; - return - New_Occurrence_Of (Get_Dynamic_Accessibility (E), Loc); + -- No_Dynamic_Accessibility_Checks restriction override for + -- alternative accessibility model. + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (E) + then + -- In the alternative model the level depends on the + -- entity's context. + + if Debug_Flag_Underscore_B then + if Is_Formal (E) then + return Make_Level_Literal + (Subprogram_Access_Level + (Enclosing_Subprogram (E))); + end if; + + return Make_Level_Literal + (Scope_Depth (Enclosing_Dynamic_Scope (E))); + end if; + + -- Otherwise the level is that of the designated type + + return Make_Level_Literal + (Typ_Access_Level (Etype (E))); + end if; + + -- Return the dynamic level in the normal case + + return New_Occurrence_Of + (Get_Dynamic_Accessibility (E), Loc); -- Initialization procedures have a special extra accessitility -- parameter associated with the level at which the object @@ -635,8 +700,18 @@ package body Sem_Util is -- according to RM 3.10.2 (21). elsif Is_Type (E) then - return Make_Level_Literal - (Type_Access_Level (E) + 1); + -- When restriction No_Dynamic_Accessibility_Checks is active + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (E) + and then not Debug_Flag_Underscore_B + then + return Make_Level_Literal (Typ_Access_Level (E)); + end if; + + -- Normal path + + return Make_Level_Literal (Typ_Access_Level (E) + 1); -- Move up the renamed entity if it came from source since -- expansion may have created a dummy renaming under certain @@ -651,7 +726,7 @@ package body Sem_Util is elsif Is_Named_Access_Type (Etype (E)) then return Make_Level_Literal - (Type_Access_Level (Etype (E))); + (Typ_Access_Level (Etype (E))); -- When E is a component of the current instance of a -- protected type, we assume the level to be deeper than that of @@ -702,7 +777,7 @@ package body Sem_Util is elsif Is_Named_Access_Type (Etype (Pre)) then return Make_Level_Literal - (Type_Access_Level (Etype (Pre))); + (Typ_Access_Level (Etype (Pre))); -- The current expression is a named access type, so there is no -- reason to look at the prefix. Instead obtain the level of E's @@ -710,7 +785,7 @@ package body Sem_Util is elsif Is_Named_Access_Type (Etype (E)) then return Make_Level_Literal - (Type_Access_Level (Etype (E))); + (Typ_Access_Level (Etype (E))); -- A nondiscriminant selected component where the component -- is an anonymous access type means that its associated @@ -723,8 +798,21 @@ package body Sem_Util is and then Ekind (Entity (Selector_Name (E))) = E_Discriminant) then + -- When restriction No_Dynamic_Accessibility_Checks is active + -- the level is that of the designated type. + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (E) + and then not Debug_Flag_Underscore_B + then + return Make_Level_Literal + (Typ_Access_Level (Etype (E))); + end if; + + -- Otherwise proceed normally + return Make_Level_Literal - (Type_Access_Level (Etype (Prefix (E)))); + (Typ_Access_Level (Etype (Prefix (E)))); -- Similar to the previous case - arrays featuring components of -- anonymous access components get their corresponding level from @@ -736,8 +824,21 @@ package body Sem_Util is and then Ekind (Component_Type (Base_Type (Etype (Pre)))) = E_Anonymous_Access_Type then + -- When restriction No_Dynamic_Accessibility_Checks is active + -- the level is that of the designated type. + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (E) + and then not Debug_Flag_Underscore_B + then + return Make_Level_Literal + (Typ_Access_Level (Etype (E))); + end if; + + -- Otherwise proceed normally + return Make_Level_Literal - (Type_Access_Level (Etype (Prefix (E)))); + (Typ_Access_Level (Etype (Prefix (E)))); -- The accessibility calculation routine that handles function -- calls (Function_Call_Level) assumes, in the case the @@ -785,7 +886,7 @@ package body Sem_Util is when N_Qualified_Expression => if Is_Named_Access_Type (Etype (E)) then return Make_Level_Literal - (Type_Access_Level (Etype (E))); + (Typ_Access_Level (Etype (E))); else return Accessibility_Level (Expression (E)); end if; @@ -804,7 +905,7 @@ package body Sem_Util is -- its type. if Is_Named_Access_Type (Etype (Pre)) then - return Make_Level_Literal (Type_Access_Level (Etype (Pre))); + return Make_Level_Literal (Typ_Access_Level (Etype (Pre))); -- Otherwise, recurse deeper @@ -831,7 +932,7 @@ package body Sem_Util is elsif Is_Named_Access_Type (Etype (E)) then return Make_Level_Literal - (Type_Access_Level (Etype (E))); + (Typ_Access_Level (Etype (E))); -- In section RM 3.10.2 (10/4) the accessibility rules for -- aggregates and value conversions are outlined. Are these @@ -847,7 +948,7 @@ package body Sem_Util is -- expression's entity. when others => - return Make_Level_Literal (Type_Access_Level (Etype (E))); + return Make_Level_Literal (Typ_Access_Level (Etype (E))); end case; end Accessibility_Level; @@ -7102,12 +7203,25 @@ package body Sem_Util is -- Deepest_Type_Access_Level -- ------------------------------- - function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is + function Deepest_Type_Access_Level + (Typ : Entity_Id; + Allow_Alt_Model : Boolean := True) return Uint + is begin if Ekind (Typ) = E_Anonymous_Access_Type and then not Is_Local_Anonymous_Access (Typ) and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration then + -- No_Dynamic_Accessibility_Checks override for alternative + -- accessibility model. + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (Typ) + and then Debug_Flag_Underscore_B + then + return Type_Access_Level (Typ, Allow_Alt_Model); + end if; + -- Typ is the type of an Ada 2012 stand-alone object of an anonymous -- access type. @@ -7123,7 +7237,7 @@ package body Sem_Util is return UI_From_Int (Int'Last); else - return Type_Access_Level (Typ); + return Type_Access_Level (Typ, Allow_Alt_Model); end if; end Deepest_Type_Access_Level; @@ -28982,12 +29096,14 @@ package body Sem_Util is -- Type_Access_Level -- ----------------------- - function Type_Access_Level (Typ : Entity_Id) return Uint is - Btyp : Entity_Id; + function Type_Access_Level + (Typ : Entity_Id; + Allow_Alt_Model : Boolean := True) return Uint + is + Btyp : Entity_Id := Base_Type (Typ); + Def_Ent : Entity_Id; begin - Btyp := Base_Type (Typ); - -- Ada 2005 (AI-230): For most cases of anonymous access types, we -- simply use the level where the type is declared. This is true for -- stand-alone object declarations, and for anonymous access types @@ -28998,13 +29114,50 @@ package body Sem_Util is if Is_Access_Type (Btyp) then if Ekind (Btyp) = E_Anonymous_Access_Type then + -- No_Dynamic_Accessibility_Checks restriction override for + -- alternative accessibility model. + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (Btyp) + then + -- In the normal model, the level of an anonymous access + -- type is always that of the designated type. + + if not Debug_Flag_Underscore_B then + return Type_Access_Level + (Designated_Type (Btyp), Allow_Alt_Model); + end if; + + -- Otherwise the secondary model dictates special handling + -- depending on the context of the anonymous access type. + + -- Obtain the defining entity for the internally generated + -- anonymous access type. + + Def_Ent := Defining_Entity_Or_Empty + (Associated_Node_For_Itype (Typ)); + + if Present (Def_Ent) then + -- When the type comes from an anonymous access parameter, + -- the level is that of the subprogram declaration. + + if Ekind (Def_Ent) in Subprogram_Kind then + return Scope_Depth (Def_Ent); + + -- When the type is an access discriminant, the level is + -- that of the type. + + elsif Ekind (Def_Ent) = E_Discriminant then + return Scope_Depth (Scope (Def_Ent)); + end if; + end if; -- If the type is a nonlocal anonymous access type (such as for -- an access parameter) we treat it as being declared at the -- library level to ensure that names such as X.all'access don't -- fail static accessibility checks. - if not Is_Local_Anonymous_Access (Typ) then + elsif not Is_Local_Anonymous_Access (Typ) then return Scope_Depth (Standard_Standard); -- If this is a return object, the accessibility level is that of @@ -29038,7 +29191,7 @@ package body Sem_Util is -- Treat the return object's type as having the level of the -- function's result subtype (as per RM05-6.5(5.3/2)). - return Type_Access_Level (Etype (Scop)); + return Type_Access_Level (Etype (Scop), Allow_Alt_Model); end; end if; end if; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 0894d034085f..a49272e080f2 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -65,15 +65,19 @@ package Sem_Util is function Accessibility_Level (Expr : Node_Id; Level : Accessibility_Level_Kind; - In_Return_Context : Boolean := False) return Node_Id; + In_Return_Context : Boolean := False; + Allow_Alt_Model : Boolean := True) return Node_Id; -- Centralized accessibility level calculation routine for finding the -- accessibility level of a given expression Expr. - -- In_Return_Context forcing the Accessibility_Level calculations to be + -- In_Return_Context forces the Accessibility_Level calculations to be -- carried out "as if" Expr existed in a return value. This is useful for -- calculating the accessibility levels for discriminant associations -- and return aggregates. + -- The Allow_Alt_Model parameter allows the alternative level calculation + -- under the restriction No_Dynamic_Accessibility_Checks to be performed. + function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String; -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to get -- the given string argument, adding leading and trailing asterisks if they @@ -662,7 +666,10 @@ package Sem_Util is -- when pragma Restrictions (No_Finalization) applies, in which case we -- know that class-wide objects do not contain controlled parts. - function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint; + function Deepest_Type_Access_Level + (Typ : Entity_Id; + Allow_Alt_Model : Boolean := True) return Uint; + -- Same as Type_Access_Level, except that if the type is the type of an Ada -- 2012 stand-alone object of an anonymous access type, then return the -- static accessibility level of the object. In that case, the dynamic @@ -672,6 +679,9 @@ package Sem_Util is -- in the case of a descendant of a generic formal type (returns Int'Last -- instead of 0). + -- The Allow_Alt_Model parameter allows the alternative level calculation + -- under the restriction No_Dynamic_Accessibility_Checks to be performed. + function Defining_Entity (N : Node_Id) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the -- declaration has a specification, the entity is obtained from the @@ -3246,9 +3256,14 @@ package Sem_Util is -- returned, i.e. Traverse_More_Func is called and the result is simply -- discarded. - function Type_Access_Level (Typ : Entity_Id) return Uint; + function Type_Access_Level + (Typ : Entity_Id; + Allow_Alt_Model : Boolean := True) return Uint; -- Return the accessibility level of Typ + -- The Allow_Alt_Model parameter allows the alternative level calculation + -- under the restriction No_Dynamic_Accessibility_Checks to be performed. + function Type_Without_Stream_Operation (T : Entity_Id; Op : TSS_Name_Type := TSS_Null) return Entity_Id; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 837a878cfdad..a67623b788b6 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -827,6 +827,7 @@ package Snames is Name_No_Access_Parameter_Allocators : constant Name_Id := N + $; Name_No_Coextensions : constant Name_Id := N + $; Name_No_Dependence : constant Name_Id := N + $; + Name_No_Dynamic_Accessibility_Checks : constant Name_Id := N + $; Name_No_Dynamic_Attachment : constant Name_Id := N + $; Name_No_Dynamic_Interrupts : constant Name_Id := N + $; Name_No_Elaboration_Code : constant Name_Id := N + $;