public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-650] [Ada] Wrong interface dynamic dispatch via access parameter
@ 2022-05-19 14:07 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2022-05-19 14:07 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:8a03acaace9544249583e630153e73d53ccfaec7
commit r13-650-g8a03acaace9544249583e630153e73d53ccfaec7
Author: Javier Miranda <miranda@adacore.com>
Date: Wed Apr 13 16:27:59 2022 +0000
[Ada] Wrong interface dynamic dispatch via access parameter
When the prefix of an Access attribute is an explicit dereference of an
access parameter (or a renaming of such a dereference, or a subcomponent
of such a dereference), the context is a general access type to a
class-wide interface type, and an accessibility check must be generated,
the frontend silently skips generating an implicit type conversion to
force the displacement of the pointer to reference the secondary
dispatch table.
gcc/ada/
* exp_attr.adb (Add_Implicit_Interface_Type_Conversion): New
subprogram which factorizes code.
(Expand_N_Attribute_Reference): Call the new subprogram to add
the missing implicit interface type conversion.
Diff:
---
gcc/ada/exp_attr.adb | 136 +++++++++++++++++++++++++++++++--------------------
1 file changed, 84 insertions(+), 52 deletions(-)
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 19aea23771a..ad7545353e3 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -2108,12 +2108,86 @@ package body Exp_Attr is
Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
Btyp_DDT : Entity_Id;
+ procedure Add_Implicit_Interface_Type_Conversion;
+ -- Ada 2005 (AI-251): The designated type is an interface type;
+ -- add an implicit type conversion to force the displacement of
+ -- the pointer to reference the secondary dispatch table.
+
function Enclosing_Object (N : Node_Id) return Node_Id;
-- If N denotes a compound name (selected component, indexed
-- component, or slice), returns the name of the outermost such
-- enclosing object. Otherwise returns N. If the object is a
-- renaming, then the renamed object is returned.
+ --------------------------------------------
+ -- Add_Implicit_Interface_Type_Conversion --
+ --------------------------------------------
+
+ procedure Add_Implicit_Interface_Type_Conversion is
+ begin
+ pragma Assert (Is_Interface (Btyp_DDT));
+
+ -- Handle cases were no action is required.
+
+ if not Comes_From_Source (N)
+ and then not Comes_From_Source (Ref_Object)
+ and then (Nkind (Ref_Object) not in N_Has_Chars
+ or else Chars (Ref_Object) /= Name_uInit)
+ then
+ return;
+ end if;
+
+ -- Common case
+
+ if Nkind (Ref_Object) /= N_Explicit_Dereference then
+
+ -- No implicit conversion required if types match, or if
+ -- the prefix is the class_wide_type of the interface. In
+ -- either case passing an object of the interface type has
+ -- already set the pointer correctly.
+
+ if Btyp_DDT = Etype (Ref_Object)
+ or else
+ (Is_Class_Wide_Type (Etype (Ref_Object))
+ and then
+ Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object))
+ then
+ null;
+
+ else
+ Rewrite (Prefix (N),
+ Convert_To (Btyp_DDT,
+ New_Copy_Tree (Prefix (N))));
+
+ Analyze_And_Resolve (Prefix (N), Btyp_DDT);
+ end if;
+
+ -- When the object is an explicit dereference, convert the
+ -- dereference's prefix.
+
+ else
+ declare
+ Obj_DDT : constant Entity_Id :=
+ Base_Type
+ (Directly_Designated_Type
+ (Etype (Prefix (Ref_Object))));
+ begin
+ -- No implicit conversion required if designated types
+ -- match.
+
+ if Obj_DDT /= Btyp_DDT
+ and then not (Is_Class_Wide_Type (Obj_DDT)
+ and then Etype (Obj_DDT) = Btyp_DDT)
+ then
+ Rewrite (N,
+ Convert_To (Typ,
+ New_Copy_Tree (Prefix (Ref_Object))));
+ Analyze_And_Resolve (N, Typ);
+ end if;
+ end;
+ end if;
+ end Add_Implicit_Interface_Type_Conversion;
+
----------------------
-- Enclosing_Object --
----------------------
@@ -2398,62 +2472,20 @@ package body Exp_Attr is
then
Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
+ -- Ada 2005 (AI-251): If the designated type is an interface we
+ -- add an implicit conversion to force the displacement of the
+ -- pointer to reference the secondary dispatch table.
+
+ if Is_Interface (Btyp_DDT) then
+ Add_Implicit_Interface_Type_Conversion;
+ end if;
+
-- Ada 2005 (AI-251): If the designated type is an interface we
-- add an implicit conversion to force the displacement of the
-- pointer to reference the secondary dispatch table.
- elsif Is_Interface (Btyp_DDT)
- and then (Comes_From_Source (N)
- or else Comes_From_Source (Ref_Object)
- or else (Nkind (Ref_Object) in N_Has_Chars
- and then Chars (Ref_Object) = Name_uInit))
- then
- if Nkind (Ref_Object) /= N_Explicit_Dereference then
-
- -- No implicit conversion required if types match, or if
- -- the prefix is the class_wide_type of the interface. In
- -- either case passing an object of the interface type has
- -- already set the pointer correctly.
-
- if Btyp_DDT = Etype (Ref_Object)
- or else (Is_Class_Wide_Type (Etype (Ref_Object))
- and then
- Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object))
- then
- null;
-
- else
- Rewrite (Prefix (N),
- Convert_To (Btyp_DDT,
- New_Copy_Tree (Prefix (N))));
-
- Analyze_And_Resolve (Prefix (N), Btyp_DDT);
- end if;
-
- -- When the object is an explicit dereference, convert the
- -- dereference's prefix.
-
- else
- declare
- Obj_DDT : constant Entity_Id :=
- Base_Type
- (Directly_Designated_Type
- (Etype (Prefix (Ref_Object))));
- begin
- -- No implicit conversion required if designated types
- -- match.
-
- if Obj_DDT /= Btyp_DDT
- and then not (Is_Class_Wide_Type (Obj_DDT)
- and then Etype (Obj_DDT) = Btyp_DDT)
- then
- Rewrite (N,
- Convert_To (Typ,
- New_Copy_Tree (Prefix (Ref_Object))));
- Analyze_And_Resolve (N, Typ);
- end if;
- end;
- end if;
+ elsif Is_Interface (Btyp_DDT) then
+ Add_Implicit_Interface_Type_Conversion;
end if;
end Access_Cases;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-05-19 14:07 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-05-19 14:07 [gcc r13-650] [Ada] Wrong interface dynamic dispatch via access parameter Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).