From: Javier Miranda <[email protected]>
The patch enforces checks on access to interface type conversions
internally generated by the frontend to displace the pointer to
a tagged type object (pointer named "this" in the C++ terminology)
from a dispatch table to a another dispatch table.
gcc/ada/ChangeLog:
* exp_util.ads (Flag_Interface_Pointer_Displacement): New subprogram.
* exp_util.adb (Flag_Interface_Pointer_Displacement): Ditto.
* exp_attr.adb (Add_Implicit_Interface_Type_Conversion): Flag type
conversions internally added to displace the pointer to the object.
(Expand_N_Attribute_Reference): Ditto.
* exp_ch4.adb (Displace_Allocator_Pointer): Ditto.
* exp_ch6.adb (Expand_Simple_Function_Return): Ditto.
(Make_Build_In_Place_Call_In_Allocator): Ditto.
(Make_CPP_Constructor_Call_In_Allocator): Ditto.
* exp_disp.adb (Expand_Interface_Actuals): Ditto.
* exp_intr.adb (Expand_Dispatching_Constructor_Call): Ditto.
* sem_ch6.adb (Analyze_Function_Return): Ditto.
* sem_disp.adb (Propagate_Tag): Ditto.
* sem_res.adb (Resolve_Actuals): Ditto.
(Valid_Conversion): Rely on the new flag to handle the type conversion
as a conversion added to displace the pointer to the object. Factorize
code handling general and anonymous access types.
* sem_type.adb (Interface_Present_In_Ancestor): For concurrent types
add missing handling of class-wide types. Noticed working on this
issue.
* sinfo.ads (Is_Interface_Pointer_Displacement): Document this new flag.
* gen_il-fields.ads (Is_Interface_Pointer_Displacement): New flag.
* gen_il-gen-gen_nodes.adb (Is_Interface_Pointer_Displacement): New
flag on N_Type_Conversion nodes.
* gen_il-internals.adb (Image): Add Is_Interface_Pointer_Displacement
flag image.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_attr.adb | 4 ++
gcc/ada/exp_ch4.adb | 1 +
gcc/ada/exp_ch6.adb | 6 ++
gcc/ada/exp_disp.adb | 3 +
gcc/ada/exp_intr.adb | 4 ++
gcc/ada/exp_util.adb | 11 +++
gcc/ada/exp_util.ads | 7 ++
gcc/ada/gen_il-fields.ads | 1 +
gcc/ada/gen_il-gen-gen_nodes.adb | 1 +
gcc/ada/gen_il-internals.adb | 2 +
gcc/ada/sem_ch6.adb | 2 +
gcc/ada/sem_disp.adb | 1 +
gcc/ada/sem_res.adb | 116 ++++---------------------------
gcc/ada/sem_type.adb | 7 +-
gcc/ada/sinfo.ads | 7 ++
15 files changed, 69 insertions(+), 104 deletions(-)
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index f9436f78a41..8bf95095d1b 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -2651,6 +2651,7 @@ package body Exp_Attr is
Rewrite (Prefix (N),
Convert_To (Btyp_DDT,
New_Copy_Tree (Prefix (N))));
+ Flag_Interface_Pointer_Displacement (Prefix (N));
Analyze_And_Resolve (Prefix (N), Btyp_DDT);
end if;
@@ -2675,6 +2676,8 @@ package body Exp_Attr is
Rewrite (N,
Convert_To (Typ,
New_Copy_Tree (Prefix (Ref_Object))));
+ Flag_Interface_Pointer_Displacement (N);
+
Analyze_And_Resolve (N, Typ);
end if;
end;
@@ -3127,6 +3130,7 @@ package body Exp_Attr is
Designated_Type (Etype (Parent (N)));
begin
Rewrite (Pref, Convert_To (Iface_Typ, Relocate_Node (Pref)));
+ Flag_Interface_Pointer_Displacement (Pref);
Analyze_And_Resolve (Pref, Iface_Typ);
return;
end;
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 94944fcb032..2b52fc70175 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -548,6 +548,7 @@ package body Exp_Ch4 is
-- the secondary dispatch table.
Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
+ Flag_Interface_Pointer_Displacement (N);
Analyze_And_Resolve (N, Dtyp);
-- 3) The 'access to the secondary dispatch table will be used
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 72288631d3d..eb141839a3e 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -7724,6 +7724,7 @@ package body Exp_Ch6 is
if Is_Interface (R_Type) then
Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
+ Flag_Interface_Pointer_Displacement (Exp);
end if;
Analyze_And_Resolve (Exp, R_Type);
@@ -7802,6 +7803,7 @@ package body Exp_Ch6 is
if Is_Interface (R_Type) then
Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
+ Flag_Interface_Pointer_Displacement (Exp);
end if;
Analyze_And_Resolve (Exp, R_Type);
@@ -7996,6 +7998,7 @@ package body Exp_Ch6 is
and then Utyp /= Underlying_Type (Exp_Typ)
then
Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp)));
+ Flag_Interface_Pointer_Displacement (Exp);
Analyze_And_Resolve (Exp);
end if;
@@ -9196,6 +9199,7 @@ package body Exp_Ch6 is
Rewrite
(Ref_Func_Call,
OK_Convert_To (Acc_Type, Ref_Func_Call));
+ Flag_Interface_Pointer_Displacement (Ref_Func_Call);
-- If the types are incompatible, we need an unchecked conversion. Note
-- that the full types will be compatible, but the types not visibly
@@ -10002,6 +10006,7 @@ package body Exp_Ch6 is
Rewrite (Allocator,
Convert_To (Etype (Allocator),
New_Occurrence_Of (Tmp_Id, Loc)));
+ Flag_Interface_Pointer_Displacement (Allocator);
end Make_Build_In_Place_Iface_Call_In_Allocator;
---------------------------------------------------------
@@ -10219,6 +10224,7 @@ package body Exp_Ch6 is
if Is_Interface (Designated_Type (Acc_Type)) then
Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator)));
+ Flag_Interface_Pointer_Displacement (Allocator);
end if;
Analyze_And_Resolve (Allocator, Acc_Type);
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index ea3706fe8c7..f19ccac11d0 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1708,6 +1708,7 @@ package body Exp_Disp is
end if;
Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
+ Flag_Interface_Pointer_Displacement (Conversion);
Rewrite (Actual, Conversion);
Analyze_And_Resolve (Actual, Formal_Typ);
end if;
@@ -1776,6 +1777,8 @@ package body Exp_Disp is
Conversion := Convert_To (Formal_Typ, Actual_Dup);
Rewrite (Actual, Conversion);
+ Flag_Interface_Pointer_Displacement (Actual);
+
Analyze_And_Resolve (Actual, Formal_Typ);
end if;
end if;
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index bb1e5816691..2949b9cc43f 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -415,6 +415,10 @@ package body Exp_Intr is
Rewrite (N, Convert_To (Result_Typ, Cnstr_Call));
+ if Is_Interface (Result_Typ) then
+ Flag_Interface_Pointer_Displacement (N);
+ end if;
+
-- Do not generate a run-time check on the built object if tag
-- checks are suppressed for the result type or tagged type expansion
-- is disabled or if CodePeer_Mode.
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index c5c70daac17..4dc4b03da68 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -7127,6 +7127,17 @@ package body Exp_Util is
end if;
end Find_Hook_Context;
+ -----------------------------------------
+ -- Flag_Interface_Pointer_Displacement --
+ -----------------------------------------
+
+ procedure Flag_Interface_Pointer_Displacement (N : Node_Id) is
+ begin
+ if Nkind (N) = N_Type_Conversion then
+ Set_Is_Interface_Pointer_Displacement (N);
+ end if;
+ end Flag_Interface_Pointer_Displacement;
+
------------------------------
-- Following_Address_Clause --
------------------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index b7d8a185f4b..c866acd76b8 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -680,6 +680,12 @@ package Exp_Util is
-- be evaluated, for example if N is the right operand of a short circuit
-- operator.
+ procedure Flag_Interface_Pointer_Displacement (N : Node_Id);
+ -- If N is an N_Type_Conversion node then flag N to indicate that this
+ -- type conversion was internally added to force the displacement of the
+ -- pointer to the object (pointer named "this" in the C++ terminology)
+ -- from a dispatch table to another dispatch table.
+
function Following_Address_Clause (D : Node_Id) return Node_Id;
-- D is the node for an object declaration. This function searches the
-- current declarative part to look for an address clause for the object
@@ -1370,6 +1376,7 @@ private
pragma Inline (Duplicate_Subexpr);
pragma Inline (Find_Controlled_Prim_Op);
pragma Inline (Find_Prim_Op);
+ pragma Inline (Flag_Interface_Pointer_Displacement);
pragma Inline (Force_Evaluation);
pragma Inline (Get_Mapped_Entity);
pragma Inline (Is_Library_Level_Tagged_Type);
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 9c10406d4b6..8e05c187474 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -263,6 +263,7 @@ package Gen_IL.Fields is
Is_Implicit_With,
Is_In_Discriminant_Check,
Is_Initialization_Block,
+ Is_Interface_Pointer_Displacement,
Is_Interpolated_String_Literal,
Is_Known_Guaranteed_ABE,
Is_Machine_Number,
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index e6e00ff986d..9334c98e394 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -476,6 +476,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sm (Do_Length_Check, Flag),
Sm (Do_Overflow_Check, Flag),
Sm (Float_Truncate, Flag),
+ Sm (Is_Interface_Pointer_Displacement, Flag),
Sm (Tag_Propagated, Flag),
Sm (Rounded_Result, Flag)));
diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb
index 0595bc54fc1..cd0f715cbd5 100644
--- a/gcc/ada/gen_il-internals.adb
+++ b/gcc/ada/gen_il-internals.adb
@@ -315,6 +315,8 @@ package body Gen_IL.Internals is
return "Is_Elaboration_Warnings_OK_Node";
when Is_IEEE_Extended_Precision =>
return "Is_IEEE_Extended_Precision";
+ when Is_Interface_Pointer_Displacement =>
+ return "Is_Interface_Pointer_Displacement";
when Is_Known_Guaranteed_ABE =>
return "Is_Known_Guaranteed_ABE";
when Is_RACW_Stub_Type =>
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index a6db10512b6..0629dda91a9 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -886,6 +886,8 @@ package body Sem_Ch6 is
Designated_Type (Etype (Expr)))
then
Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
+ Flag_Interface_Pointer_Displacement (Expr);
+
Analyze (Expr);
end if;
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 4a940e7f30b..0e89af8f0a7 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -3324,6 +3324,7 @@ package body Sem_Disp is
Subtype_Mark =>
New_Occurrence_Of (Etype (Control), Sloc (Call_Node)),
Expression => Relocate_Node (Call_Node)));
+ Flag_Interface_Pointer_Displacement (Call_Node);
Set_Etype (Call_Node, Etype (Control));
Set_Analyzed (Call_Node);
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 885f51fe012..a0287f1abe5 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -4561,6 +4561,8 @@ package body Sem_Res is
and then Is_Interface (DDT)
then
Rewrite (A, Convert_To (Etype (F), Relocate_Node (A)));
+ Flag_Interface_Pointer_Displacement (A);
+
Analyze_And_Resolve (A, Etype (F),
Suppress => Access_Check);
end if;
@@ -14325,111 +14327,13 @@ package body Sem_Res is
-- reference the corresponding dispatch table.
elsif not Comes_From_Source (N)
+ and then Nkind (N) = N_Type_Conversion
and then Is_Access_Type (Target_Type)
and then Is_Interface (Designated_Type (Target_Type))
+ and then Is_Interface_Pointer_Displacement (N)
then
return True;
- -- Ada 2005 (AI-251): Anonymous access types where target references an
- -- interface type.
-
- elsif Is_Access_Type (Opnd_Type)
- and then Ekind (Target_Type) in
- E_General_Access_Type | E_Anonymous_Access_Type
- and then Is_Interface (Directly_Designated_Type (Target_Type))
- then
- -- Check the static accessibility rule of 4.6(17). Note that the
- -- check is not enforced when within an instance body, since the
- -- RM requires such cases to be caught at run time.
-
- -- If the operand is a rewriting of an allocator no check is needed
- -- because there are no accessibility issues.
-
- if Nkind (Original_Node (N)) = N_Allocator then
- null;
-
- elsif Ekind (Target_Type) /= E_Anonymous_Access_Type then
- if Type_Access_Level (Opnd_Type) >
- Deepest_Type_Access_Level (Target_Type)
- then
- -- In an instance, this is a run-time check, but one we know
- -- will fail, so generate an appropriate warning. The raise
- -- will be generated by Expand_N_Type_Conversion.
-
- if In_Instance_Body then
- Error_Msg_Warn := SPARK_Mode /= On;
- Report_Error_N
- ("cannot convert local pointer to non-local access type<<",
- Operand, Report_Errs);
- Report_Error_N ("\Program_Error [<<", Operand, Report_Errs);
-
- else
- Report_Error_N
- ("cannot convert local pointer to non-local access type",
- Operand, Report_Errs);
- return False;
- end if;
-
- -- Special accessibility checks are needed in the case of access
- -- discriminants declared for a limited type.
-
- elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
- and then not Is_Local_Anonymous_Access (Opnd_Type)
- then
- -- When the operand is a selected access discriminant the check
- -- needs to be made against the level of the object denoted by
- -- the prefix of the selected name (Accessibility_Level handles
- -- checking the prefix of the operand for this case).
-
- if Nkind (Operand) = N_Selected_Component
- and then Static_Accessibility_Level
- (Operand, Zero_On_Dynamic_Level)
- > Deepest_Type_Access_Level (Target_Type)
- then
- -- In an instance, this is a run-time check, but one we know
- -- will fail, so generate an appropriate warning. The raise
- -- will be generated by Expand_N_Type_Conversion.
-
- if In_Instance_Body then
- Error_Msg_Warn := SPARK_Mode /= On;
- Report_Error_N
- ("cannot convert access discriminant to non-local "
- & "access type<<", Operand, Report_Errs);
- Report_Error_N
- ("\Program_Error [<<", Operand, Report_Errs);
-
- -- Real error if not in instance body
-
- else
- Report_Error_N
- ("cannot convert access discriminant to non-local "
- & "access type", Operand, Report_Errs);
- return False;
- end if;
- end if;
-
- -- The case of a reference to an access discriminant from
- -- within a limited type declaration (which will appear as
- -- a discriminal) is always illegal because the level of the
- -- discriminant is considered to be deeper than any (nameable)
- -- access type.
-
- if Is_Entity_Name (Operand)
- and then not Is_Local_Anonymous_Access (Opnd_Type)
- and then
- Ekind (Entity (Operand)) in E_In_Parameter | E_Constant
- and then Present (Discriminal_Link (Entity (Operand)))
- then
- Report_Error_N
- ("discriminant has deeper accessibility level than target",
- Operand, Report_Errs);
- return False;
- end if;
- end if;
- end if;
-
- return True;
-
-- General and anonymous access types
elsif Ekind (Target_Type) in
@@ -14484,10 +14388,16 @@ package body Sem_Res is
end;
-- Check the static accessibility rule of 4.6(17). Note that the
- -- check is not enforced when within an instance body, since the RM
- -- requires such cases to be caught at run time.
+ -- check is not enforced when within an instance body, since the
+ -- RM requires such cases to be caught at run time.
- if Ekind (Target_Type) /= E_Anonymous_Access_Type
+ -- If the operand is a rewriting of an allocator no check is needed
+ -- because there are no accessibility issues.
+
+ if Nkind (Original_Node (N)) = N_Allocator then
+ null;
+
+ elsif Ekind (Target_Type) /= E_Anonymous_Access_Type
or else Is_Local_Anonymous_Access (Target_Type)
or else Nkind (Associated_Node_For_Itype (Target_Type)) =
N_Object_Declaration
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 86fd0012492..ceaed45efcf 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -2685,7 +2685,12 @@ package body Sem_Type is
end if;
if Is_Concurrent_Record_Type (Target_Typ) then
- Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
+ if Is_Class_Wide_Type (Target_Typ) then
+ Target_Typ :=
+ Corresponding_Concurrent_Type (Root_Type (Target_Typ));
+ else
+ Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
+ end if;
end if;
Target_Typ := Base_Type (Target_Typ);
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 8a35fdc4208..c5d981d5302 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -1739,6 +1739,12 @@ package Sinfo is
-- composed of interpolated string elements from string literals found
-- in interpolated expressions.
+ -- Is_Interface_Pointer_Displacement
+ -- This flag is set in N_Type_Conversion nodes, and is used to indicate
+ -- that the type conversion was generated to displace the pointer to one
+ -- tagged object (pointer named "this" in the C++ terminology) from a
+ -- dispatch table to another dispatch table.
+
-- Is_Known_Guaranteed_ABE
-- Note: this flag is shared between the legacy ABE mechanism and the
-- default ABE mechanism.
@@ -4757,6 +4763,7 @@ package Sinfo is
-- Do_Overflow_Check
-- Rounded_Result
-- Tag_Propagated
+ -- Is_Interface_Pointer_Displacement
-- plus fields for expression
-- Note: if a range check is required, then the Do_Range_Check flag
--
2.51.0
