https://gcc.gnu.org/g:4de3be28bab44350548cb559b61f69cc040b4016
commit r16-2413-g4de3be28bab44350548cb559b61f69cc040b4016
Author: Javier Miranda <mira...@adacore.com>
Date: Mon May 12 18:46:11 2025 +0000
ada: Wrong dispatch on result in presence of dependent expression
The compiler generates wrong code in a dispatching call on result
when the call is performed under dependent conditional expressions
or case-expressions.
gcc/ada/ChangeLog:
* sinfo.ads (Is_Expanded_Dispatching_Call): New flag.
(Tag_Propagated): New flag.
* exp_ch6.adb (Expand_Call_Helper): Propagate the tag when
the dispatching call is placed in conditionl expressions or
case-expressions.
* sem_ch5.adb (Analyze_Assignment): For assignment of tag-
indeterminate expression, do not propagate the tag if
previously done.
* sem_disp.adb (Is_Tag_Indeterminate): Add missing support
for conditional expression and case expression.
* exp_disp.ads (Is_Expanded_Dispatching_Call): Removed. Function
replaced by a new flag in the nodes.
* exp_disp.adb (Expand_Dispatching_Call): Set a flag in the
call node to remember that the call has been expanded.
(Is_Expanded_Dispatching_Call): Function removed.
* gen_il-fields.ads (Tag_Propagated): New flag.
(Is_Expanded_Dispatching_Call): New flag.
* gen_il-gen-gen_nodes.adb (Tag_Propagated): New flag.
(Is_Expanded_Dispatching_Call): New flag.
Diff:
---
gcc/ada/exp_ch6.adb | 49 ++++++++++++++++++++++++++++------------
gcc/ada/exp_disp.adb | 15 +++---------
gcc/ada/exp_disp.ads | 3 ---
gcc/ada/gen_il-fields.ads | 2 ++
gcc/ada/gen_il-gen-gen_nodes.adb | 9 ++++++--
gcc/ada/sem_ch5.adb | 9 +++++++-
gcc/ada/sem_disp.adb | 47 ++++++++++++++++++++++++++++++++++++++
gcc/ada/sinfo.ads | 36 +++++++++++++++++++++--------
8 files changed, 127 insertions(+), 43 deletions(-)
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 81686abbad81..1195582aaeab 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -4756,27 +4756,34 @@ package body Exp_Ch6 is
then
declare
Ass : Node_Id := Empty;
+ Par : Node_Id := Parent (Call_Node);
begin
- if Nkind (Parent (Call_Node)) = N_Assignment_Statement then
- Ass := Parent (Call_Node);
+ -- Search for the LHS of an enclosing assignment statement to a
+ -- classwide type object (if present) and propagate the tag to
+ -- this function call.
+
+ while Nkind (Par) in N_Case_Expression
+ | N_Case_Expression_Alternative
+ | N_Explicit_Dereference
+ | N_If_Expression
+ | N_Qualified_Expression
+ | N_Unchecked_Type_Conversion
+ loop
+ if Nkind (Par) = N_Case_Expression_Alternative then
+ Par := Parent (Par);
+ end if;
- elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression
- and then Nkind (Parent (Parent (Call_Node))) =
- N_Assignment_Statement
- then
- Ass := Parent (Parent (Call_Node));
+ exit when not Is_Tag_Indeterminate (Par);
- elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference
- and then Nkind (Parent (Parent (Call_Node))) =
- N_Assignment_Statement
- then
- Ass := Parent (Parent (Call_Node));
- end if;
+ Par := Parent (Par);
+ end loop;
- if Present (Ass)
- and then Is_Class_Wide_Type (Etype (Name (Ass)))
+ if Nkind (Par) = N_Assignment_Statement
+ and then Is_Class_Wide_Type (Etype (Name (Par)))
then
+ Ass := Par;
+
-- Move the error messages below to sem???
if Is_Access_Type (Etype (Call_Node)) then
@@ -4789,6 +4796,12 @@ package body Exp_Ch6 is
Call_Node, Root_Type (Etype (Name (Ass))));
else
Propagate_Tag (Name (Ass), Call_Node);
+
+ -- Remember that the tag has been propagated to avoid
+ -- propagating it again, as part of the (bottom-up)
+ -- analysis of the enclosing assignment.
+
+ Set_Tag_Propagated (Name (Ass));
end if;
elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then
@@ -4799,6 +4812,12 @@ package body Exp_Ch6 is
else
Propagate_Tag (Name (Ass), Call_Node);
+
+ -- Remember that the tag has been propagated to avoid
+ -- propagating it again, as part of the (bottom-up)
+ -- analysis of the enclosing assignment.
+
+ Set_Tag_Propagated (Name (Ass));
end if;
-- The call will be rewritten as a dispatching call, and
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 6cd4f6a515c2..619ac407cb0a 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -801,7 +801,7 @@ package body Exp_Disp is
-- No action needed if the dispatching call has been already expanded
- or else Is_Expanded_Dispatching_Call (Name (Call_Node))
+ or else Is_Expanded_Dispatching_Call (Call_Node)
then
return;
end if;
@@ -1209,6 +1209,8 @@ package body Exp_Disp is
-- the generation of spurious warnings under ZFP run-time.
Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
+
+ Set_Is_Expanded_Dispatching_Call (Call_Node);
end Expand_Dispatching_Call;
---------------------------------
@@ -2350,17 +2352,6 @@ package body Exp_Disp is
and then not Restriction_Active (No_Dispatching_Calls);
end Has_DT;
- ----------------------------------
- -- Is_Expanded_Dispatching_Call --
- ----------------------------------
-
- function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean is
- begin
- return Nkind (N) in N_Subprogram_Call
- and then Nkind (Name (N)) = N_Explicit_Dereference
- and then Is_Dispatch_Table_Entity (Etype (Name (N)));
- end Is_Expanded_Dispatching_Call;
-
-------------------------------------
-- Is_Predefined_Dispatching_Alias --
-------------------------------------
diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads
index 3cba8ca447e3..76f592358005 100644
--- a/gcc/ada/exp_disp.ads
+++ b/gcc/ada/exp_disp.ads
@@ -236,9 +236,6 @@ package Exp_Disp is
function Has_CPP_Constructors (Typ : Entity_Id) return Boolean;
-- Returns true if the type has CPP constructors
- function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean;
- -- Returns true if N is the expanded code of a dispatching call
-
function Make_DT (Typ : Entity_Id) return List_Id;
-- Expand the declarations for the Dispatch Table of Typ
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 68adcf4a71a6..18edec26742c 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -255,6 +255,7 @@ package Gen_IL.Fields is
Is_Entry_Barrier_Function,
Is_Expanded_Build_In_Place_Call,
Is_Expanded_Constructor_Call,
+ Is_Expanded_Dispatching_Call,
Is_Expanded_Prefixed_Call,
Is_Folded_In_Parser,
Is_Generic_Contract_Pragma,
@@ -400,6 +401,7 @@ package Gen_IL.Fields is
Suppress_Loop_Warnings,
Synchronized_Present,
Tagged_Present,
+ Tag_Propagated,
Target,
Call_Or_Target_Loop,
Target_Type,
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index f4e79173502c..412565f42a8b 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -149,6 +149,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sm (Is_Controlling_Actual, Flag),
Sm (Is_Overloaded, Flag),
Sm (Is_Static_Expression, Flag),
+ Sm (Is_Expanded_Dispatching_Call, Flag),
Sm (Must_Not_Freeze, Flag),
Sm (Raises_Constraint_Error, Flag)));
@@ -181,7 +182,8 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sm (Is_Elaboration_Warnings_OK_Node, Flag),
Sm (Is_SPARK_Mode_On_Node, Flag),
Sm (Original_Discriminant, Node_Id),
- Sm (Redundant_Use, Flag)));
+ Sm (Redundant_Use, Flag),
+ Sm (Tag_Propagated, Flag)));
Cc (N_Operator_Symbol, N_Direct_Name,
(Sy (Strval, String_Id)));
@@ -346,7 +348,8 @@ begin -- Gen_IL.Gen.Gen_Nodes
(Sy (Prefix, Node_Id),
Sm (Actual_Designated_Subtype, Node_Id),
Sm (Atomic_Sync_Required, Flag),
- Sm (Has_Dereference_Action, Flag)));
+ Sm (Has_Dereference_Action, Flag),
+ Sm (Tag_Propagated, Flag)));
Cc (N_Expression_With_Actions, N_Subexpr,
(Sy (Actions, List_Id, Default_No_List),
@@ -463,6 +466,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sm (Do_Length_Check, Flag),
Sm (Do_Overflow_Check, Flag),
Sm (Float_Truncate, Flag),
+ Sm (Tag_Propagated, Flag),
Sm (Rounded_Result, Flag)));
Cc (N_Unchecked_Type_Conversion, N_Subexpr,
@@ -905,6 +909,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sm (Cleanup_Actions, List_Id),
Sm (Exception_Junk, Flag),
Sm (Is_Abort_Block, Flag),
+ Sm (Is_Expanded_Dispatching_Call, Flag),
Sm (Is_Initialization_Block, Flag),
Sm (Is_Task_Master, Flag)));
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index e1d6be424ed4..0661e64d095d 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -807,7 +807,14 @@ package body Sem_Ch5 is
if Is_Tag_Indeterminate (Rhs) then
if Is_Class_Wide_Type (T1) then
- Propagate_Tag (Lhs, Rhs);
+
+ -- No need to propagate the tag when the RHS has function calls
+ -- that already propagated it (see Expand_Call_Helper), or if
+ -- some error was reported analyzing RHS.
+
+ if not (Error_Posted (Rhs) or else Tag_Propagated (Lhs)) then
+ Propagate_Tag (Lhs, Rhs);
+ end if;
elsif Nkind (Rhs) = N_Function_Call
and then Is_Entity_Name (Name (Rhs))
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index b70c7b4fea44..5a8bd58b8b81 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -3085,6 +3085,52 @@ package body Sem_Disp is
then
return Is_Tag_Indeterminate (Prefix (Orig_Node));
+ -- An if-expression is tag-indeterminate if all of the dependent
+ -- expressions are tag-indeterminate (RM 4.5.7 (17/3)).
+
+ elsif Nkind (Orig_Node) = N_If_Expression then
+ declare
+ Cond : constant Node_Id := First (Expressions (Orig_Node));
+ Expr : Node_Id := Next (Cond);
+
+ begin
+ if not Is_Tag_Indeterminate (Original_Node (Expr)) then
+ return False;
+ end if;
+
+ Next (Expr);
+
+ if Present (Expr)
+ and then not Is_Tag_Indeterminate (Original_Node (Expr))
+ then
+ return False;
+ end if;
+
+ return True;
+ end;
+
+ -- A case-expression is tag-indeterminate if all of the dependent
+ -- expressions are tag-indeterminate (RM 4.5.7 (17/3)).
+
+ elsif Nkind (Orig_Node) = N_Case_Expression then
+ declare
+ Alt : Node_Id := First (Alternatives (Orig_Node));
+ Expr : Node_Id;
+
+ begin
+ while Present (Alt) loop
+ Expr := Expression (Alt);
+
+ if not Is_Tag_Indeterminate (Original_Node (Expr)) then
+ return False;
+ end if;
+
+ Next (Alt);
+ end loop;
+
+ return True;
+ end;
+
else
return False;
end if;
@@ -3245,6 +3291,7 @@ package body Sem_Disp is
elsif Nkind (Actual) = N_Explicit_Dereference
and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call
then
+ pragma Assert (Is_Expanded_Dispatching_Call (Actual));
return;
-- When expansion is suppressed, an unexpanded call to 'Input can occur,
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index c63a97dbcc63..3d11d5c5aa67 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -402,16 +402,17 @@ package Sinfo is
-- Has_Secondary_Private_View set in generic units
-- "plus fields for expression"
- -- Paren_Count number of parentheses levels
- -- Etype type of the expression
- -- Is_Overloaded >1 type interpretation exists
- -- Is_Static_Expression set for static expression
- -- Raises_Constraint_Error evaluation raises CE
- -- Must_Not_Freeze set if must not freeze
- -- Do_Range_Check set if a range check needed
- -- Has_Dynamic_Length_Check set if length check inserted
- -- Assignment_OK set if modification is OK
- -- Is_Controlling_Actual set for controlling argument
+ -- Paren_Count number of parentheses levels
+ -- Etype type of the expression
+ -- Is_Overloaded >1 type interpretation exists
+ -- Is_Static_Expression set for static expression
+ -- Raises_Constraint_Error evaluation raises CE
+ -- Must_Not_Freeze set if must not freeze
+ -- Do_Range_Check set if a range check needed
+ -- Has_Dynamic_Length_Check set if length check inserted
+ -- Assignment_OK set if modification is OK
+ -- Is_Controlling_Actual set for controlling argument
+ -- Is_Expanded_Dispatching_Call set for expanded dispatching calls
-- Note: see under (EXPRESSION) for further details on the use of
-- the Paren_Count field to record the number of parentheses levels.
@@ -1664,6 +1665,10 @@ package Sinfo is
-- actuals to support a build-in-place style of call have been added to
-- the call.
+ -- Is_Expanded_Dispatching_Call
+ -- This flag is set in N_Block_Statement, and expression nodes to
+ -- indicate that it is an expanded dispatching call.
+
-- Is_Expanded_Prefixed_Call
-- This flag is set in N_Function_Call and N_Procedure_Call_Statement
-- nodes to indicate that it is an expanded prefixed call.
@@ -2321,6 +2326,13 @@ package Sinfo is
-- statement applies to. Finally, if Analyze_Continue_Statement detects
-- an error, this field is set to Empty.
+ -- Tag_Propagated
+ -- This flag is set in N_Identifier, N_Explicit_Dereference, and N_Type_
+ -- Conversion nodes that are the LHS of an assignment statement. Used to
+ -- remember that the RHS of the assignment has tag indeterminate function
+ -- calls and the tag has been propagated to the calls (as part of the
+ -- bottom-up analysis of the RHS of the assignment statement).
+
-- Target_Type
-- Used in an N_Validate_Unchecked_Conversion node to point to the target
-- type entity for the unchecked conversion instantiation which gigi must
@@ -2507,6 +2519,7 @@ package Sinfo is
-- Has_Private_View (set in generic units)
-- Has_Secondary_Private_View (set in generic units)
-- Redundant_Use
+ -- Tag_Propagated
-- Atomic_Sync_Required
-- plus fields for expression
@@ -3820,6 +3833,7 @@ package Sinfo is
-- Prefix
-- Actual_Designated_Subtype
-- Has_Dereference_Action
+ -- Tag_Propagated
-- Atomic_Sync_Required
-- plus fields for expression
@@ -4755,6 +4769,7 @@ package Sinfo is
-- Conversion_OK
-- Do_Overflow_Check
-- Rounded_Result
+ -- Tag_Propagated
-- plus fields for expression
-- Note: if a range check is required, then the Do_Range_Check flag
@@ -5196,6 +5211,7 @@ package Sinfo is
-- Has_Created_Identifier
-- Is_Abort_Block
-- Is_Asynchronous_Call_Block
+ -- Is_Expanded_Dispatching_Call
-- Is_Initialization_Block
-- Is_Task_Allocation_Block
-- Is_Task_Master
