https://gcc.gnu.org/g:fb97610cfdd26f08915fe083d3ab566c151ba320
commit r16-5389-gfb97610cfdd26f08915fe083d3ab566c151ba320 Author: Javier Miranda <[email protected]> Date: Thu Oct 2 06:41:32 2025 +0000 ada: Enforce checks on access to interface type conversions 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. Diff: --- 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 f9436f78a41c..8bf95095d1be 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 94944fcb032b..2b52fc70175b 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 72288631d3d4..eb141839a3ef 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 ea3706fe8c79..f19ccac11d0b 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 bb1e58166916..2949b9cc43fb 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 c5c70daac17e..4dc4b03da68d 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 b7d8a185f4bd..c866acd76b8f 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 9c10406d4b60..8e05c187474d 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 e6e00ff986de..9334c98e3945 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 0595bc54fc19..cd0f715cbd57 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 a6db10512b62..0629dda91a91 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 4a940e7f30bd..0e89af8f0a77 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 885f51fe0127..a0287f1abe57 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 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; - if Ekind (Target_Type) /= E_Anonymous_Access_Type + 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 86fd00124925..ceaed45efcff 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 8a35fdc42082..c5d981d53023 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
