From: Martin Clochard <cloch...@adacore.com>
Implicit wrapper overridings generated for functions with
controlling result when deriving with null extension may
have field Overridden_Operation incorrectly set, when making
several such derivations in succession. This happens because
overridings were assumed to come from source, and entities
generated by Derive_Subprograms were also assumed to be
derived from source subprograms. Overridden_Operation could
be set to the entity generated by Derive_Subprograms for the
same type, resulting in a cycle between Overriden_Operation
and Alias fields, causing non-termination in GNATprove.
gcc/ada/
* sem_ch6.adb (Check_Overriding_Indicator) Remove Comes_From_Source
filter.
(New_Overloaded_Entity) Move up special case of LSP_Subprogram,
and remove Comes_From_Source filter.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch6.adb | 82 +++++++++++++++++++--------------------------
1 file changed, 35 insertions(+), 47 deletions(-)
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index e97afdaf12e..43aa2e636fa 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -6916,13 +6916,11 @@ package body Sem_Ch6 is
-- operation is the inherited primitive (which is available
-- through the attribute alias)
- if (Is_Dispatching_Operation (Subp)
- or else Is_Dispatching_Operation (Overridden_Subp))
+ if Is_Dispatching_Operation (Subp)
and then not Comes_From_Source (Overridden_Subp)
and then Find_Dispatching_Type (Overridden_Subp) =
Find_Dispatching_Type (Subp)
and then Present (Alias (Overridden_Subp))
- and then Comes_From_Source (Alias (Overridden_Subp))
then
Set_Overridden_Operation (Subp, Alias (Overridden_Subp));
Inherit_Subprogram_Contract (Subp, Alias (Overridden_Subp));
@@ -12565,16 +12563,25 @@ package body Sem_Ch6 is
Enter_Overloaded_Entity (S);
+ -- LSP wrappers must override the ultimate alias of their
+ -- wrapped dispatching primitive E; required to traverse the
+ -- chain of ancestor primitives (see Map_Primitives). They
+ -- don't inherit contracts.
+
+ if Is_Wrapper (S)
+ and then Present (LSP_Subprogram (S))
+ then
+ Set_Overridden_Operation (S, Ultimate_Alias (E));
+
-- For entities generated by Derive_Subprograms the
-- overridden operation is the inherited primitive
-- (which is available through the attribute alias).
- if not (Comes_From_Source (E))
+ elsif not (Comes_From_Source (E))
and then Is_Dispatching_Operation (E)
and then Find_Dispatching_Type (E) =
Find_Dispatching_Type (S)
and then Present (Alias (E))
- and then Comes_From_Source (Alias (E))
then
Set_Overridden_Operation (S, Alias (E));
Inherit_Subprogram_Contract (S, Alias (E));
@@ -12591,20 +12598,8 @@ package body Sem_Ch6 is
-- must check whether the target is an init_proc.
elsif not Is_Init_Proc (S) then
-
- -- LSP wrappers must override the ultimate alias of their
- -- wrapped dispatching primitive E; required to traverse
- -- the chain of ancestor primitives (c.f. Map_Primitives)
- -- They don't inherit contracts.
-
- if Is_Wrapper (S)
- and then Present (LSP_Subprogram (S))
- then
- Set_Overridden_Operation (S, Ultimate_Alias (E));
- else
- Set_Overridden_Operation (S, E);
- Inherit_Subprogram_Contract (S, E);
- end if;
+ Set_Overridden_Operation (S, E);
+ Inherit_Subprogram_Contract (S, E);
Set_Is_Ada_2022_Only (S, Is_Ada_2022_Only (E));
end if;
@@ -12619,37 +12614,30 @@ package body Sem_Ch6 is
-- If S is a user-defined subprogram or a null procedure
-- expanded to override an inherited null procedure, or a
- -- predefined dispatching primitive then indicate that E
- -- overrides the operation from which S is inherited.
+ -- predefined dispatching primitive, or a function wrapper
+ -- expanded to override an inherited function with
+ -- dispatching result, then indicate that S overrides the
+ -- operation from which E is inherited.
- if Comes_From_Source (S)
- or else
- (Present (Parent (S))
- and then Nkind (Parent (S)) = N_Procedure_Specification
- and then Null_Present (Parent (S)))
- or else
- (Present (Alias (E))
- and then
- Is_Predefined_Dispatching_Operation (Alias (E)))
+ if (not Is_Wrapper (S) or else No (LSP_Subprogram (S)))
+ and then Present (Alias (E))
+ and then
+ (Comes_From_Source (S)
+ or else
+ (Nkind (Parent (S)) = N_Procedure_Specification
+ and then Null_Present (Parent (S)))
+ or else Is_Predefined_Dispatching_Operation (Alias (E))
+ or else
+ (E in E_Function_Id
+ and then Is_Dispatching_Operation (E)
+ and then Has_Controlling_Result (E)
+ and then Is_Wrapper (S)
+ and then not Is_Dispatch_Table_Wrapper (S)))
then
- if Present (Alias (E)) then
-
- -- LSP wrappers must override the ultimate alias of
- -- their wrapped dispatching primitive E; required to
- -- traverse the chain of ancestor primitives (see
- -- Map_Primitives). They don't inherit contracts.
-
- if Is_Wrapper (S)
- and then Present (LSP_Subprogram (S))
- then
- Set_Overridden_Operation (S, Ultimate_Alias (E));
- else
- Set_Overridden_Operation (S, Alias (E));
- Inherit_Subprogram_Contract (S, Alias (E));
- end if;
+ Set_Overridden_Operation (S, Alias (E));
+ Inherit_Subprogram_Contract (S, Alias (E));
- Set_Is_Ada_2022_Only (S, Is_Ada_2022_Only (Alias (E)));
- end if;
+ Set_Is_Ada_2022_Only (S, Is_Ada_2022_Only (Alias (E)));
end if;
if Is_Dispatching_Operation (E) then
--
2.45.2
