From: Javier Miranda <mira...@adacore.com>
gcc/ada/
* sem_ch3.adb (Add_Internal_Interface_Entities): Add missing
subtype-conformance check on primitives implementing interface
primitives.
(Error_Posted_In_Formals): New subprogram.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch3.adb | 105 ++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 105 insertions(+)
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 042ace01724..3262236dd14 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -1688,6 +1688,31 @@ package body Sem_Ch3 is
-------------------------------------
procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is
+
+ function Error_Posted_In_Formals (Subp : Entity_Id) return Boolean;
+ -- Determine if an error has been posted in some formal of Subp.
+
+ -----------------------------
+ -- Error_Posted_In_Formals --
+ -----------------------------
+
+ function Error_Posted_In_Formals (Subp : Entity_Id) return Boolean is
+ Formal : Entity_Id := First_Formal (Subp);
+
+ begin
+ while Present (Formal) loop
+ if Error_Posted (Formal) then
+ return True;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ return False;
+ end Error_Posted_In_Formals;
+
+ -- Local variables
+
Elmt : Elmt_Id;
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
@@ -1741,6 +1766,86 @@ package body Sem_Ch3 is
pragma Assert (Present (Prim));
+ -- Check subtype conformance; we skip this check if errors have
+ -- been reported in the primitive (or in the formals of the
+ -- primitive) because Find_Primitive_Covering_Interface relies
+ -- on the subprogram Type_Conformant to locate the primitive,
+ -- and reports errors if the formals don't match.
+
+ if not Error_Posted (Prim)
+ and then not Error_Posted_In_Formals (Prim)
+ then
+ declare
+ Alias_Prim : Entity_Id;
+ Alias_Typ : Entity_Id;
+ Err_Loc : Node_Id := Empty;
+ Ret_Type : Entity_Id;
+
+ begin
+ -- For inherited primitives, in case of reporting an
+ -- error, the error must be reported on this primitive
+ -- (i.e. in the name of its type declaration); otherwise
+ -- the error would be reported in the formal of the
+ -- alias primitive defined on its parent type.
+
+ if Nkind (Parent (Prim)) = N_Full_Type_Declaration then
+ Err_Loc := Prim;
+ end if;
+
+ -- Check subtype conformance of procedures, functions
+ -- with matching return type, or functions not returning
+ -- interface types.
+
+ if Ekind (Prim) = E_Procedure
+ or else Etype (Iface_Prim) = Etype (Prim)
+ or else not Is_Interface (Etype (Iface_Prim))
+ then
+ Check_Subtype_Conformant
+ (New_Id => Prim,
+ Old_Id => Iface_Prim,
+ Err_Loc => Err_Loc,
+ Skip_Controlling_Formals => True);
+
+ -- Check subtype conformance of functions returning an
+ -- interface type; temporarily force both entities to
+ -- return the same type. Required because subprogram
+ -- Subtype_Conformant does not handle this case.
+
+ else
+ Ret_Type := Etype (Iface_Prim);
+ Set_Etype (Iface_Prim, Etype (Prim));
+
+ Check_Subtype_Conformant
+ (New_Id => Prim,
+ Old_Id => Iface_Prim,
+ Err_Loc => Err_Loc,
+ Skip_Controlling_Formals => True);
+
+ Set_Etype (Iface_Prim, Ret_Type);
+ end if;
+
+ -- Complete the error when reported on inherited
+ -- primitives.
+
+ if Nkind (Parent (Prim)) = N_Full_Type_Declaration
+ and then (Error_Posted (Prim)
+ or else Error_Posted_In_Formals (Prim))
+ and then Present (Alias (Prim))
+ then
+ Alias_Prim := Ultimate_Alias (Prim);
+ Alias_Typ := Find_Dispatching_Type (Alias_Prim);
+
+ if Alias_Typ /= Tagged_Type
+ and then Is_Ancestor (Alias_Typ, Tagged_Type)
+ then
+ Error_Msg_Sloc := Sloc (Alias_Prim);
+ Error_Msg_N
+ ("in primitive inherited from #!", Prim);
+ end if;
+ end if;
+ end;
+ end if;
+
-- Ada 2012 (AI05-0197): If the name of the covering primitive
-- differs from the name of the interface primitive then it is
-- a private primitive inherited from a parent type. In such
--
2.40.0
