From: Eric Botcazou <[email protected]>
The computation of accessibility levels does not consistently look through
object renamings when extra accessibility objects are used. This attempts
to address the issue by making Extra_Accessibility do it automatically.
gcc/ada/ChangeLog:
* einfo.ads (Extra_Accessibility): Rename to...
(Extra_Accessibility_Of_Object): ...this and adjust description.
* gen_il-fields.ads (Opt_Field_Enum): Replace Extra_Accessibility
with Extra_Accessibility_Of_Object.
* gen_il-gen-gen_entities.adb (Constant_Or_Variable_Kind): Ditto.
(Formal_Kind): Ditto.
* accessibility.ads (Effective_Extra_Accessibility): Rename to...
(Extra_Accessibility): ...this.
* accessibility.adb (Apply_Accessibility_Check_For_Parameter): Do
not manually look through renamings and adjust.
(Effective_Extra_Accessibility): Rename to...
(Extra_Accessibility): ...this and add guard.
* exp_ch3.adb (Expand_N_Object_Declaration): Adjust.
* exp_ch4.adb (Expand_N_Type_Conversion): Likewise.
* exp_ch5.adb (Expand_N_Assignment_Statement): Likewise.
* exp_ch6.adb (Expand_Actuals): Likewise.
* sem_ch3.adb (Derive_Subprogram): Likewise.
* sem_ch6.adb (Create_Extra_Formals): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/accessibility.adb | 54 +++++++++++++++--------------
gcc/ada/accessibility.ads | 5 +--
gcc/ada/einfo.ads | 26 +++++++-------
gcc/ada/exp_ch3.adb | 2 +-
gcc/ada/exp_ch4.adb | 26 ++------------
gcc/ada/exp_ch5.adb | 5 ++-
gcc/ada/exp_ch6.adb | 5 ++-
gcc/ada/gen_il-fields.ads | 2 +-
gcc/ada/gen_il-gen-gen_entities.adb | 4 +--
gcc/ada/sem_ch3.adb | 2 +-
gcc/ada/sem_ch6.adb | 2 +-
11 files changed, 57 insertions(+), 76 deletions(-)
diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index 36ecd0a3546..a8ba9c85ec3 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -1558,42 +1558,40 @@ package body Accessibility is
Loc : constant Source_Ptr := Sloc (N);
Check_Cond : Node_Id;
- Param_Ent : Entity_Id := Param_Entity (N);
+ Param_Ent : Entity_Id;
Param_Level : Node_Id;
Type_Level : Node_Id;
begin
+ if Inside_A_Generic then
+ return;
+ end if;
+
-- Verify we haven't tried to add a dynamic accessibility check when we
-- shouldn't.
pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N));
+ Param_Ent := Param_Entity (N);
+
+ -- Stand-alone object of an anonymous access type (SAOOAAAT)
+
if Ada_Version >= Ada_2012
and then No (Param_Ent)
and then Is_Entity_Name (N)
and then Ekind (Entity (N)) in E_Constant | E_Variable
- and then Present (Effective_Extra_Accessibility (Entity (N)))
+ and then Present (Extra_Accessibility (Entity (N)))
then
Param_Ent := Entity (N);
- while Present (Renamed_Object (Param_Ent)) loop
- -- Renamed_Object must return an Entity_Name here
- -- because of preceding "Present (E_E_A (...))" test.
-
- Param_Ent := Entity (Renamed_Object (Param_Ent));
- end loop;
end if;
- if Inside_A_Generic then
- return;
+ -- Apply the run-time check only if the access object has an associated
+ -- extra access level object and when accessibility checks are enabled.
- -- Only apply the run-time check if the access parameter has an
- -- associated extra access level parameter and when accessibility checks
- -- are enabled.
-
- elsif Present (Param_Ent)
- and then Present (Get_Dynamic_Accessibility (Param_Ent))
- and then not Accessibility_Checks_Suppressed (Param_Ent)
- and then not Accessibility_Checks_Suppressed (Typ)
+ if Present (Param_Ent)
+ and then Present (Get_Dynamic_Accessibility (Param_Ent))
+ and then not Accessibility_Checks_Suppressed (Param_Ent)
+ and then not Accessibility_Checks_Suppressed (Typ)
then
-- Obtain the parameter's accessibility level
@@ -2268,20 +2266,24 @@ package body Accessibility is
end if;
end Deepest_Type_Access_Level;
- -----------------------------------
- -- Effective_Extra_Accessibility --
- -----------------------------------
+ -------------------------
+ -- Extra_Accessibility --
+ -------------------------
- function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
+ function Extra_Accessibility (Id : Entity_Id) return Entity_Id is
begin
if Present (Renamed_Object (Id))
and then Is_Entity_Name (Renamed_Object (Id))
then
- return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
- else
- return Extra_Accessibility (Id);
+ return Extra_Accessibility (Entity (Renamed_Object (Id)));
end if;
- end Effective_Extra_Accessibility;
+
+ if Is_Formal (Id) or else Ekind (Id) in E_Constant | E_Variable then
+ return Extra_Accessibility_Of_Object (Id);
+ else
+ return Empty;
+ end if;
+ end Extra_Accessibility;
-------------------------------
-- Get_Dynamic_Accessibility --
diff --git a/gcc/ada/accessibility.ads b/gcc/ada/accessibility.ads
index 3b52986a1fb..cfec56d3507 100644
--- a/gcc/ada/accessibility.ads
+++ b/gcc/ada/accessibility.ads
@@ -138,8 +138,9 @@ package Accessibility is
-- The Allow_Alt_Model parameter allows the alternative level calculation
-- under the restriction No_Dynamic_Accessibility_Checks to be performed.
- function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id;
- -- Same as Extra_Accessibility in Einfo, but looks through object renamings
+ function Extra_Accessibility (Id : Entity_Id) return Entity_Id;
+ -- Same as Extra_Accessibility_Of_Object in Einfo, but looks through object
+ -- renamings per the RM 3.10.2(8) rule.
function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id;
-- Obtain the accessibility level for a given entity formal taking into
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index b156de6ee05..8d8ee1cd362 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -1251,17 +1251,17 @@ package Einfo is
-- Note one obscure case: for pragma Default_Storage_Pool (null), the
-- Etype of the N_Null node is Empty.
--- Extra_Accessibility
--- Defined in formal parameters in the non-generic case. Normally Empty,
--- but if expansion is active, and a parameter is one for which a
+-- Extra_Accessibility_Of_Object
+-- Defined in formal parameters in the non-generic case: normally Empty,
+-- but if expansion is active, and a formal parameter is one for which a
-- dynamic accessibility check is required, then an extra formal of type
-- Natural is created (see description of field Extra_Formal), and the
--- Extra_Accessibility field of the formal parameter points to the entity
--- for this extra formal. Also defined in variables when compiling
--- receiving stubs. In this case, a non Empty value means that this
--- variable's accessibility depth has been transmitted by the caller and
--- must be retrieved through the entity designed by this field instead of
--- being computed.
+-- Extra_Accessibility_Of_Object of the formal parameter points to the
+-- entity of this extra formal. Defined in stand-alone objects: normally
+-- Empty, but if expansion is active, and the object is one for which a
+-- dynamic accessibility check is required (AI05-0148), then a variable
+-- of type Natural is created and the Extra_Accessibility_Of_Object of
+-- the object points to the entity of this variable.
-- Extra_Accessibility_Of_Result
-- Defined in (non-generic) Function, Operator, and Subprogram_Type
@@ -1289,7 +1289,7 @@ package Einfo is
-- parameters require extra implicit information to be passed (e.g. the
-- flag indicating if an unconstrained variant record argument is
-- constrained, and the accessibility level for access parameters). See
--- description of Extra_Constrained, Extra_Accessibility fields for
+-- description of Extra_Constrained and Extra_Accessibility_Of_Object for
-- further details. Extra formal parameters are constructed to represent
-- these values, and chained to the end of the list of formals using the
-- Extra_Formal field (i.e. the Extra_Formal field of the last "real"
@@ -5392,7 +5392,7 @@ package Einfo is
-- Discriminal_Link
-- Full_View
-- Esize
- -- Extra_Accessibility (constants only)
+ -- Extra_Accessibility_Of_Object (constants only)
-- Alignment
-- Actual_Subtype
-- Renamed_Object
@@ -5744,7 +5744,7 @@ package Einfo is
-- Discriminal_Link (discriminals only)
-- Entry_Component
-- Esize
- -- Extra_Accessibility
+ -- Extra_Accessibility_Of_Object
-- Alignment
-- Extra_Formal
-- Unset_Reference
@@ -6292,7 +6292,7 @@ package Einfo is
-- Part_Of_Constituents
-- Part_Of_References
-- Esize
- -- Extra_Accessibility
+ -- Extra_Accessibility_Of_Object
-- Alignment
-- Unset_Reference
-- Actual_Subtype
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 036a8010631..b67e784c6c4 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -8771,7 +8771,7 @@ package body Exp_Ch3 is
Insert_Action_After (Init_After, Level_Decl);
- Set_Extra_Accessibility (Def_Id, Level);
+ Set_Extra_Accessibility_Of_Object (Def_Id, Level);
end;
end if;
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index b90107f09ca..41448c9df61 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -11531,10 +11531,6 @@ package body Exp_Ch4 is
procedure Real_Range_Check;
-- Handles generation of range check for real target value
- function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
- -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
- -- evaluates to True.
-
function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id)
return Boolean;
-- Given a target type for a conversion, determine whether the
@@ -12047,22 +12043,6 @@ package body Exp_Ch4 is
Rewrite (Expr, New_Occurrence_Of (Tnn, Loc));
end Real_Range_Check;
- -----------------------------
- -- Has_Extra_Accessibility --
- -----------------------------
-
- -- Returns true for a formal of an anonymous access type or for an Ada
- -- 2012-style stand-alone object of an anonymous access type.
-
- function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
- begin
- if Is_Formal (Id) or else Ekind (Id) in E_Constant | E_Variable then
- return Present (Effective_Extra_Accessibility (Id));
- else
- return False;
- end if;
- end Has_Extra_Accessibility;
-
----------------------------------------
-- Statically_Deeper_Relation_Applies --
----------------------------------------
@@ -12342,9 +12322,9 @@ package body Exp_Ch4 is
-- subprogram call. Note that other checks may still need to be
-- applied below (such as tagged type checks).
- elsif Is_Entity_Name (Operand_Acc)
- and then Has_Extra_Accessibility (Entity (Operand_Acc))
- and then Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type
+ elsif Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type
+ and then Is_Entity_Name (Operand_Acc)
+ and then Present (Extra_Accessibility (Entity (Operand_Acc)))
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)
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index ead0425214c..5d7c78f82f6 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -2871,7 +2871,7 @@ package body Exp_Ch5 is
if Is_Access_Type (Typ)
and then Is_Entity_Name (Lhs)
and then Ekind (Entity (Lhs)) /= E_Loop_Parameter
- and then Present (Effective_Extra_Accessibility (Entity (Lhs)))
+ and then Present (Extra_Accessibility (Entity (Lhs)))
then
if not Accessibility_Checks_Suppressed (Entity (Lhs)) then
Insert_Action (N,
@@ -2888,8 +2888,7 @@ package body Exp_Ch5 is
Insert_Action (N,
Make_Assignment_Statement (Loc,
Name =>
- New_Occurrence_Of
- (Effective_Extra_Accessibility (Entity (Lhs)), Loc),
+ New_Occurrence_Of (Extra_Accessibility (Entity (Lhs)), Loc),
Expression =>
Accessibility_Level
(Expr => Rhs,
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 79359f5f846..a31dd269d92 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -1803,8 +1803,7 @@ package body Exp_Ch6 is
if Is_Access_Type (E_Formal)
and then Is_Entity_Name (Lhs)
- and then
- Present (Effective_Extra_Accessibility (Entity (Lhs)))
+ and then Present (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
@@ -1829,7 +1828,7 @@ package body Exp_Ch6 is
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (
- Effective_Extra_Accessibility (Entity (Lhs)), Loc),
+ Extra_Accessibility (Entity (Lhs)), Loc),
Expression => Make_Integer_Literal (Loc,
Type_Access_Level (E_Formal))));
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 31e7cb458fd..e354b242427 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -535,7 +535,7 @@ package Gen_IL.Fields is
Enumeration_Rep_Expr,
Equivalent_Type,
Esize,
- Extra_Accessibility,
+ Extra_Accessibility_Of_Object,
Extra_Accessibility_Of_Result,
Extra_Constrained,
Extra_Formal,
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb
b/gcc/ada/gen_il-gen-gen_entities.adb
index 60de3aa27d8..6d94315031d 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -347,7 +347,7 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Contract, Node_Id),
Sm (Discriminal_Link, Node_Id),
Sm (Encapsulating_State, Node_Id),
- Sm (Extra_Accessibility, Node_Id),
+ Sm (Extra_Accessibility_Of_Object, Node_Id),
Sm (Initialization_Statements, Node_Id),
Sm (Is_Elaboration_Checks_OK_Id, Flag),
Sm (Is_Elaboration_Warnings_OK_Id, Flag),
@@ -401,7 +401,7 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Alignment, Unat),
Sm (Default_Value, Node_Id),
Sm (Entry_Component, Node_Id),
- Sm (Extra_Accessibility, Node_Id),
+ Sm (Extra_Accessibility_Of_Object, Node_Id),
Sm (Extra_Constrained, Node_Id),
Sm (Extra_Formal, Node_Id),
Sm (Has_Initial_Value, Flag),
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 1bc9e288bc6..337c99c0324 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -16868,7 +16868,7 @@ package body Sem_Ch3 is
if Is_Limited_Interface (Parent_Type) then
Set_Extra_Formal (New_Formal, Empty);
- Set_Extra_Accessibility (New_Formal, Empty);
+ Set_Extra_Accessibility_Of_Object (New_Formal, Empty);
end if;
-- Normally we do not go copying parents, but in the case of
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 95cd7c0f35e..d1704b00919 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -9306,7 +9306,7 @@ package body Sem_Ch6 is
pragma Assert (No (Alias_Formal)
or else Present (Extra_Accessibility (Alias_Formal)));
- Set_Extra_Accessibility
+ Set_Extra_Accessibility_Of_Object
(Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "L"));
else
--
2.53.0
