From: Pierre-Marie de Rodat <derodat@adacore.com>
To: gcc-patches@gcc.gnu.org
Cc: Eric Botcazou <ebotcazou@adacore.com>
Subject: [Ada] Do not make procedure call with only tag-indeternminate actuals dispatching
Date: Mon, 4 Jul 2022 07:50:29 +0000 [thread overview]
Message-ID: <20220704075029.GA99406@adacore.com> (raw)
[-- Attachment #1: Type: text/plain, Size: 628 bytes --]
The RM 3.9.2(19) clause says that the controlling tag value is statically
determined to be the tag of the tagged type involved. As a matter of fact,
the call would be made dispatching only as a by-product of the propagation
of the controlling tag value to the tag-indeternminate actuals, but that's
unnecessary and not done in the equivalent case of a procedure call with
both statically tagged and tag-indeternminate actuals.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_disp.adb (Check_Dispatching_Call): Merge the two special cases
where there are no controlling actuals but tag-indeternminate ones.
[-- Attachment #2: patch.diff --]
[-- Type: text/x-diff, Size: 5176 bytes --]
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -540,8 +540,10 @@ package body Sem_Disp is
Control : Node_Id := Empty;
Func : Entity_Id;
Subp_Entity : Entity_Id;
- Indeterm_Ancestor_Call : Boolean := False;
- Indeterm_Ctrl_Type : Entity_Id := Empty; -- init to avoid warning
+
+ Indeterm_Ctrl_Type : Entity_Id := Empty;
+ -- Type of a controlling formal whose actual is a tag-indeterminate call
+ -- whose result type is different from, but is an ancestor of, the type.
Static_Tag : Node_Id := Empty;
-- If a controlling formal has a statically tagged actual, the tag of
@@ -935,8 +937,7 @@ package body Sem_Disp is
and then Base_Type (Etype (Actual)) /= Base_Type (Etype (Formal))
and then Is_Ancestor (Etype (Actual), Etype (Formal))
then
- Indeterm_Ancestor_Call := True;
- Indeterm_Ctrl_Type := Etype (Formal);
+ Indeterm_Ctrl_Type := Etype (Formal);
-- If the formal is controlling but the actual is not, the type
-- of the actual is statically known, and may be used as the
@@ -946,39 +947,13 @@ package body Sem_Disp is
and then Is_Entity_Name (Actual)
and then Is_Tagged_Type (Etype (Actual))
then
- Static_Tag := Actual;
+ Static_Tag := Etype (Actual);
end if;
Next_Actual (Actual);
Next_Formal (Formal);
end loop;
- -- If the call doesn't have a controlling actual but does have an
- -- indeterminate actual that requires dispatching treatment, then an
- -- object is needed that will serve as the controlling argument for
- -- a dispatching call on the indeterminate actual. This can occur
- -- in the unusual situation of a default actual given by a tag-
- -- indeterminate call and where the type of the call is an ancestor
- -- of the type associated with a containing call to an inherited
- -- operation (see AI-239).
-
- -- Rather than create an object of the tagged type, which would
- -- be problematic for various reasons (default initialization,
- -- discriminants), the tag of the containing call's associated
- -- tagged type is directly used to control the dispatching.
-
- if No (Control)
- and then Indeterm_Ancestor_Call
- and then No (Static_Tag)
- then
- Control :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Indeterm_Ctrl_Type, Loc),
- Attribute_Name => Name_Tag);
-
- Analyze (Control);
- end if;
-
if Present (Control) then
-- Verify that no controlling arguments are statically tagged
@@ -1030,17 +1005,35 @@ package body Sem_Disp is
Check_Direct_Call;
- -- If there is a statically tagged actual and a tag-indeterminate
- -- call to a function of the ancestor (such as that provided by a
- -- default), then treat this as a dispatching call and propagate
- -- the tag to the tag-indeterminate call(s).
-
- elsif Present (Static_Tag) and then Indeterm_Ancestor_Call then
- Control :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Etype (Static_Tag), Loc),
- Attribute_Name => Name_Tag);
+ -- If the call doesn't have a controlling actual but does have an
+ -- indeterminate actual that requires dispatching treatment, then an
+ -- object is needed that will serve as the controlling argument for
+ -- a dispatching call on the indeterminate actual. This can occur
+ -- in the unusual situation of a default actual given by a tag-
+ -- indeterminate call and where the type of the call is an ancestor
+ -- of the type associated with a containing call to an inherited
+ -- operation (see AI-239).
+
+ -- Rather than create an object of the tagged type, which would
+ -- be problematic for various reasons (default initialization,
+ -- discriminants), the tag of the containing call's associated
+ -- tagged type is directly used to control the dispatching.
+
+ elsif Present (Indeterm_Ctrl_Type) then
+ if Present (Static_Tag) then
+ Control :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Static_Tag, Loc),
+ Attribute_Name => Name_Tag);
+
+ else
+ Control :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Indeterm_Ctrl_Type, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
Analyze (Control);
reply other threads:[~2022-07-04 7:50 UTC|newest]
Thread overview: [no followups] expand[flat|nested] mbox.gz Atom feed
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20220704075029.GA99406@adacore.com \
--to=derodat@adacore.com \
--cc=ebotcazou@adacore.com \
--cc=gcc-patches@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
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).