From: Eric Botcazou <[email protected]>
In the case of an object declaration, the function returns the depth of the
enclosing static scope, instead of that of the enclosing dynamic scope like
its parent function Accessibility_Level.
The change contains a couple of cleanups in the expander, which resort to
calling Accessibility_Level in more cases instead of doing manual work.
gcc/ada/ChangeLog:
* accessibility.ads (Accessibility_Level_Kind): Tweak description.
* accessibility.adb (Function_Call_Or_Allocator_Level): Recurse on
the defining identifier for an N_Object_Declaration node.
(Accessibility_Level): Minor tweaks.
* exp_ch3.adb (Expand_N_Object_Declaration): Do not special case
function calls in the computation of accessibility levels.
* exp_ch5.adb (Expand_N_Assignment_Statement): Do not manually
compute the accessibility level of the LHS.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/accessibility.adb | 28 ++++++-------
gcc/ada/accessibility.ads | 33 +++++++++-------
gcc/ada/exp_ch3.adb | 13 +------
gcc/ada/exp_ch5.adb | 82 +++++++++++----------------------------
4 files changed, 55 insertions(+), 101 deletions(-)
diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index f29e846a98e..36ecd0a3546 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -444,8 +444,8 @@ package body Accessibility is
when N_Object_Declaration =>
return
- Make_Level_Literal
- (Scope_Depth (Scope (Defining_Identifier (Par))));
+ Accessibility_Level
+ (Defining_Identifier (Par), Object_Decl_Level);
-- For the dynamic allocation of an object, return the
-- accessibility level of the allocator.
@@ -612,7 +612,7 @@ package body Accessibility is
-- Anonymous access types
- elsif Nkind (Pre) in N_Has_Entity
+ elsif Is_Entity_Name (Pre)
and then Ekind (Entity (Pre)) not in Subprogram_Kind
and then Present (Get_Dynamic_Accessibility (Entity (Pre)))
and then Level = Dynamic_Level
@@ -666,27 +666,26 @@ package body Accessibility is
then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
- -- Something went wrong and an extra accessibility formal has not
- -- been generated when one should have ???
+ -- Return the library level for formal parameters of an anonymous
+ -- access type without extra accessiblity formal. This may happen
+ -- for subprograms with foreign convention or when expansion is
+ -- disabled, see Sem_Ch6.Create_Extra_Formals.
elsif Is_Formal (E)
- and then No (Get_Dynamic_Accessibility (E))
and then Ekind (Etype (E)) = E_Anonymous_Access_Type
+ and then No (Get_Dynamic_Accessibility (E))
then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
- -- Stand-alone object of an anonymous access type "SAOAAT"
+ -- Formal parameters with an extra accessibility formal, as well
+ -- as stand-alone objects of an anonymous access type (SAOOAAAT).
- elsif (Is_Formal (E)
- or else Ekind (E) in E_Variable
- | E_Constant)
+ elsif (Is_Formal (E) or else Ekind (E) in E_Constant | E_Variable)
and then Present (Get_Dynamic_Accessibility (E))
- and then (Level = Dynamic_Level
- or else Level = Zero_On_Dynamic_Level)
+ and then (Level in Dynamic_Level | Zero_On_Dynamic_Level)
then
if Level = Zero_On_Dynamic_Level then
- return Make_Level_Literal
- (Scope_Depth (Standard_Standard));
+ return Make_Level_Literal (Scope_Depth (Standard_Standard));
end if;
-- No_Dynamic_Accessibility_Checks restriction override for
@@ -776,6 +775,7 @@ package body Accessibility is
elsif Level = Dynamic_Level
and then Ekind (E) in E_In_Parameter | E_In_Out_Parameter
+ and then Is_Subprogram (Scope (E))
and then Present (Init_Proc_Level_Formal (Scope (E)))
then
return New_Occurrence_Of
diff --git a/gcc/ada/accessibility.ads b/gcc/ada/accessibility.ads
index 552074e085d..3b52986a1fb 100644
--- a/gcc/ada/accessibility.ads
+++ b/gcc/ada/accessibility.ads
@@ -35,22 +35,25 @@ package Accessibility is
-- rules of 3.10.2 are violated.
type Accessibility_Level_Kind is
- (Dynamic_Level,
- Object_Decl_Level,
- Zero_On_Dynamic_Level);
- -- Accessibility_Level_Kind is an enumerated type which captures the
- -- different modes in which an accessibility level could be obtained for
- -- a given expression.
+ (Dynamic_Level, Object_Decl_Level, Zero_On_Dynamic_Level);
+ -- Captures the different modes in which an accessibility level could be
+ -- obtained for a given expression. In the context of Accessibility_Level
+ -- function, Accessibility_Level_Kind signals what type of accessibility
+ -- level to obtain.
- -- When in the context of the function Accessibility_Level,
- -- Accessibility_Level_Kind signals what type of accessibility level to
- -- obtain. For example, when Level is Dynamic_Level, a defining identifier
- -- associated with a saooaaat may be returned or an N_Integer_Literal node.
- -- When the level is Object_Decl_Level, an N_Integer_Literal node is
- -- returned containing the level of the declaration of the object if
- -- relevant (be it a saooaaat or otherwise). Finally, Zero_On_Dynamic_Level
- -- returns library level for all cases where the accessibility level is
- -- dynamic (used to bypass static accessibility checks in dynamic cases).
+ -- When Level is Dynamic_Level, a defining identifier associated with an
+ -- access parameter, an access result, or an SAOOAAAT, may be returned,
+ -- and an N_Integer_Literal node in the other cases.
+
+ -- When Level is Object_Decl_Level, an N_Integer_Literal node whose value
+ -- is the level of the declaration of the object is returned in the cases
+ -- where Dynamic_Level returns a defining identifier; in the other cases,
+ -- the same N_Integer_Literal node as Dynamic_Level is returned.
+
+ -- When Level is Zero_On_Dynamic_Level, an N_Integer_Literal node whose
+ -- value is zero (i.e. that of the library level) is returned in the cases
+ -- where Dynamic_Level returns a defining identifier; in the other cases,
+ -- the same N_Integer_Literal node as Dynamic_Level is returned.
function Accessibility_Level
(Expr : Node_Id;
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index d92ab21976d..036a8010631 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -8752,18 +8752,7 @@ package body Exp_Ch3 is
if No (Expr) then
Level_Expr :=
- Make_Integer_Literal
- (Loc, Scope_Depth (Standard_Standard));
-
- -- When the expression of the object is a function which returns
- -- an anonymous access type the master of the call is the object
- -- being initialized instead of the type.
-
- elsif Nkind (Expr) = N_Function_Call
- and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type
- then
- Level_Expr := Accessibility_Level
- (Def_Id, Object_Decl_Level);
+ Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
-- General case
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 92c1ef0bb79..ead0425214c 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -2863,7 +2863,7 @@ package body Exp_Ch5 is
Apply_Constraint_Check (Rhs, Etype (Lhs));
end if;
- -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
+ -- Ada 2012 (AI05-148): Update current accessibility level if Lhs is a
-- stand-alone obj of an anonymous access type. Do not install the check
-- when the Lhs denotes a container cursor and the Next function employs
-- an access type, because this can never result in a dangling pointer.
@@ -2873,66 +2873,28 @@ package body Exp_Ch5 is
and then Ekind (Entity (Lhs)) /= E_Loop_Parameter
and then Present (Effective_Extra_Accessibility (Entity (Lhs)))
then
- declare
- function Lhs_Entity return Entity_Id;
- -- Look through renames to find the underlying entity.
- -- For assignment to a rename, we don't care about the
- -- Enclosing_Dynamic_Scope of the rename declaration.
+ if not Accessibility_Checks_Suppressed (Entity (Lhs)) then
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Accessibility_Level (Rhs, Dynamic_Level),
+ Right_Opnd =>
+ Accessibility_Level (Lhs, Object_Decl_Level)),
+ Reason => PE_Accessibility_Check_Failed));
+ end if;
- ----------------
- -- Lhs_Entity --
- ----------------
-
- function Lhs_Entity return Entity_Id is
- Result : Entity_Id := Entity (Lhs);
-
- begin
- while Present (Renamed_Object (Result)) loop
-
- -- Renamed_Object must return an Entity_Name here
- -- because of preceding "Present (E_E_A (...))" test.
-
- Result := Entity (Renamed_Object (Result));
- end loop;
-
- return Result;
- end Lhs_Entity;
-
- -- Local Declarations
-
- Access_Check : constant Node_Id :=
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd =>
- Accessibility_Level (Rhs, Dynamic_Level),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Intval =>
- Scope_Depth
- (Enclosing_Dynamic_Scope
- (Lhs_Entity)))),
- Reason => PE_Accessibility_Check_Failed);
-
- Access_Level_Update : constant Node_Id :=
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Effective_Extra_Accessibility
- (Entity (Lhs)), Loc),
- Expression =>
- Accessibility_Level
- (Expr => Rhs,
- Level => Dynamic_Level,
- Allow_Alt_Model => False));
-
- begin
- if not Accessibility_Checks_Suppressed (Entity (Lhs)) then
- Insert_Action (N, Access_Check);
- end if;
-
- Insert_Action (N, Access_Level_Update);
- end;
+ Insert_Action (N,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Effective_Extra_Accessibility (Entity (Lhs)), Loc),
+ Expression =>
+ Accessibility_Level
+ (Expr => Rhs,
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False)));
end if;
-- Case of assignment to a bit packed array element. If there is a
--
2.53.0
