This patch modifies the implementation of AI05-0071 to allow several special cases of equality to appear in instantiations where a formal type has unknown discriminants, a defaulted equality and the actual type is class-wide.
------------ -- Source -- ------------ -- equals_gen.ads generic type Formal_Typ (<>) is private; with function "=" (L : Formal_Typ; R : Formal_Typ) return Boolean is <>; package Equals_Gen is end Equals_Gen; -- equals_types.ads package Equals_Types is type AT_1 is abstract tagged null record; function "=" (L : AT_1; R : AT_1) return Boolean; function "=" (L : AT_1'Class; R : AT_1'Class) return Boolean; type AT_2 is abstract tagged null record; function "=" (L : AT_2; R : AT_2) return Boolean; type AT_3 is abstract tagged null record; function "=" (L : AT_3'Class; R : AT_3'Class) return Boolean; type AT_4 is abstract tagged null record; type AT_5 is interface; function "=" (L : AT_5; R : AT_5) return Boolean is abstract; function "=" (L : AT_5'Class; R : AT_5'Class) return Boolean; type AT_6 is interface; function "=" (L : AT_6; R : AT_6) return Boolean is abstract; type AT_7 is interface; function "=" (L : AT_7'Class; R : AT_7'Class) return Boolean; type AT_8 is interface; end Equals_Types; -- equals_instances.ads with Equals_Gen; with Equals_Types; use Equals_Types; package Equals_Instances is package Inst_1 is new Equals_Gen (AT_1'Class); -- ERROR package Inst_2 is new Equals_Gen (AT_2'Class); -- ok package Inst_3 is new Equals_Gen (AT_3'Class); -- ok package Inst_4 is new Equals_Gen (AT_4'Class); -- ok package Inst_5 is new Equals_Gen (AT_5'Class); -- ERROR package Inst_6 is new Equals_Gen (AT_6'Class); -- ok package Inst_7 is new Equals_Gen (AT_7'Class); -- ok package Inst_8 is new Equals_Gen (AT_8'Class); -- ok end Equals_Instances; ---------------------------- -- Compilation and output -- ---------------------------- $ gcc -c equals_instances.ads equals_instances.ads:5:04: instantiation error at equals_gen.ads:3 equals_instances.ads:5:04: ambiguous actual for generic subprogram "=" equals_instances.ads:5:04: possible interpretation: "=" defined at equals_types.ads:3 equals_instances.ads:5:04: possible interpretation: "=" defined at equals_types.ads:4 equals_instances.ads:9:04: instantiation error at equals_gen.ads:3 equals_instances.ads:9:04: ambiguous actual for generic subprogram "=" equals_instances.ads:9:04: possible interpretation: "=" defined at equals_types.ads:15 equals_instances.ads:9:04: possible interpretation: "=" defined at equals_types.ads:16 Tested on x86_64-pc-linux-gnu, committed on trunk 2014-08-04 Hristian Kirtchev <kirtc...@adacore.com> * sem_ch8.adb (Build_Class_Wide_Wrapper): Handle various special cases related to equality. Remove the special processing for dispatching abstract subprograms as it is not needed. (Interpretation_Error): Add a specialized error message for predefined operators. (Is_Intrinsic_Equality): New routine. (Is_Suitable_Candidate): New routine.
Index: sem_ch8.adb =================================================================== --- sem_ch8.adb (revision 213530) +++ sem_ch8.adb (working copy) @@ -1918,6 +1918,14 @@ -- Emit a continuation error message suggesting subprogram Subp_Id as -- a possible interpretation. + function Is_Intrinsic_Equality (Subp_Id : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id denotes the intrinsic "=" + -- operator. + + function Is_Suitable_Candidate (Subp_Id : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id is a suitable candidate for + -- the role of a wrapped subprogram. + ---------------- -- Build_Call -- ---------------- @@ -2087,26 +2095,71 @@ procedure Interpretation_Error (Subp_Id : Entity_Id) is begin Error_Msg_Sloc := Sloc (Subp_Id); - Error_Msg_NE - ("\\possible interpretation: & defined #", Spec, Formal_Spec); + + if Is_Internal (Subp_Id) then + Error_Msg_NE + ("\\possible interpretation: predefined & #", + Spec, Formal_Spec); + else + Error_Msg_NE + ("\\possible interpretation: & defined #", Spec, Formal_Spec); + end if; end Interpretation_Error; + --------------------------- + -- Is_Intrinsic_Equality -- + --------------------------- + + function Is_Intrinsic_Equality (Subp_Id : Entity_Id) return Boolean is + begin + return + Ekind (Subp_Id) = E_Operator + and then Chars (Subp_Id) = Name_Op_Eq + and then Is_Intrinsic_Subprogram (Subp_Id); + end Is_Intrinsic_Equality; + + --------------------------- + -- Is_Suitable_Candidate -- + --------------------------- + + function Is_Suitable_Candidate (Subp_Id : Entity_Id) return Boolean is + begin + if No (Subp_Id) then + return False; + + -- An intrinsic subprogram is never a good candidate. This is an + -- indication of a missing primitive, either defined directly or + -- inherited from a parent tagged type. + + elsif Is_Intrinsic_Subprogram (Subp_Id) then + return False; + + else + return True; + end if; + end Is_Suitable_Candidate; + -- Local variables Actual_Typ : Entity_Id := Empty; -- The actual class-wide type for Formal_Typ + CW_Prim_OK : Boolean; CW_Prim_Op : Entity_Id; - -- The class-wide primitive (if any) which corresponds to the renamed - -- generic formal subprogram. + -- The class-wide subprogram (if available) which corresponds to the + -- renamed generic formal subprogram. Formal_Typ : Entity_Id := Empty; - -- The generic formal type (if any) with unknown discriminants + -- The generic formal type with unknown discriminants + Root_Prim_OK : Boolean; Root_Prim_Op : Entity_Id; - -- The root type primitive (if any) which corresponds to the renamed - -- generic formal subprogram. + -- The root type primitive (if available) which corresponds to the + -- renamed generic formal subprogram. + Root_Typ : Entity_Id := Empty; + -- The root type of Actual_Typ + Body_Decl : Node_Id; Formal : Node_Id; Prim_Op : Entity_Id; @@ -2128,10 +2181,19 @@ end if; -- Analyze the renamed name, but do not resolve it. The resolution is - -- completed once a suitable primitive is found. + -- completed once a suitable subprogram is found. Analyze (Nam); + -- When the renamed name denotes the intrinsic operator equals, the + -- name must be treated as overloaded. This allows for a potential + -- match against the root type's predefined equality function. + + if Is_Intrinsic_Equality (Entity (Nam)) then + Set_Is_Overloaded (Nam); + Collect_Interps (Nam); + end if; + -- Step 1: Find the generic formal type with unknown discriminants -- and its corresponding class-wide actual type from the renamed -- generic formal subprogram. @@ -2144,6 +2206,7 @@ then Formal_Typ := Etype (Formal); Actual_Typ := Get_Instance_Of (Formal_Typ); + Root_Typ := Etype (Actual_Typ); exit; end if; @@ -2157,13 +2220,15 @@ pragma Assert (Present (Formal_Typ)); - -- Step 2: Find the proper primitive which corresponds to the renamed - -- generic formal subprogram. + -- Step 2: Find the proper class-wide subprogram or primitive which + -- corresponds to the renamed generic formal subprogram. CW_Prim_Op := Find_Primitive (Actual_Typ); - Root_Prim_Op := Find_Primitive (Etype (Actual_Typ)); + CW_Prim_OK := Is_Suitable_Candidate (CW_Prim_Op); + Root_Prim_Op := Find_Primitive (Root_Typ); + Root_Prim_OK := Is_Suitable_Candidate (Root_Prim_Op); - -- The class-wide actual type has two primitives which correspond to + -- The class-wide actual type has two subprograms which correspond to -- the renamed generic formal subprogram: -- with procedure Prim_Op (Param : Formal_Typ); @@ -2171,72 +2236,54 @@ -- procedure Prim_Op (Param : Actual_Typ); -- may be inherited -- procedure Prim_Op (Param : Actual_Typ'Class); - -- Even though the declaration of the two primitives is legal, a call - -- to either one is ambiguous and therefore illegal. + -- Even though the declaration of the two subprograms is legal, a + -- call to either one is ambiguous and therefore illegal. - if Present (CW_Prim_Op) and then Present (Root_Prim_Op) then + if CW_Prim_OK and Root_Prim_OK then - -- Deal with abstract primitives + -- A user-defined primitive has precedence over a predefined one - if Is_Abstract_Subprogram (CW_Prim_Op) - or else Is_Abstract_Subprogram (Root_Prim_Op) + if Is_Internal (CW_Prim_Op) + and then not Is_Internal (Root_Prim_Op) then - -- An abstract subprogram cannot act as a generic actual, but - -- the partial parameterization of the instance may hide the - -- true nature of the actual. Emit an error when both options - -- are abstract. - - if Is_Abstract_Subprogram (CW_Prim_Op) - and then Is_Abstract_Subprogram (Root_Prim_Op) - then - Error_Msg_NE - ("abstract subprogram not allowed as generic actual", - Spec, Formal_Spec); - Interpretation_Error (CW_Prim_Op); - Interpretation_Error (Root_Prim_Op); - return; - - -- Otherwise choose the non-abstract version - - elsif Is_Abstract_Subprogram (Root_Prim_Op) then - Prim_Op := CW_Prim_Op; - - else pragma Assert (Is_Abstract_Subprogram (CW_Prim_Op)); - Prim_Op := Root_Prim_Op; - end if; - - -- If one of the candidate primitives is intrinsic, choose the - -- other (which may also be intrinsic). Preference is given to - -- the primitive of the root type. - - elsif Is_Intrinsic_Subprogram (CW_Prim_Op) then Prim_Op := Root_Prim_Op; - elsif Is_Intrinsic_Subprogram (Root_Prim_Op) then + elsif Is_Internal (Root_Prim_Op) + and then not Is_Internal (CW_Prim_Op) + then Prim_Op := CW_Prim_Op; elsif CW_Prim_Op = Root_Prim_Op then Prim_Op := Root_Prim_Op; - -- Otherwise there are two perfectly good candidates which satisfy - -- the profile of the renamed generic formal subprogram. + -- Otherwise both candidate subprograms are user-defined and + -- ambiguous. else Error_Msg_NE ("ambiguous actual for generic subprogram &", - Spec, Formal_Spec); + Spec, Formal_Spec); + Interpretation_Error (Root_Prim_Op); Interpretation_Error (CW_Prim_Op); - Interpretation_Error (Root_Prim_Op); return; end if; - elsif Present (CW_Prim_Op) then + elsif CW_Prim_OK and not Root_Prim_OK then Prim_Op := CW_Prim_Op; - elsif Present (Root_Prim_Op) then + elsif not CW_Prim_OK and Root_Prim_OK then Prim_Op := Root_Prim_Op; - -- Otherwise there are no candidate primitives. Let the caller + -- An intrinsic equality may act as a suitable candidate in the case + -- of a null type extension where the parent's equality is hidden. A + -- call to an intrinsic equality is expanded as dispatching. + + elsif Present (Root_Prim_Op) + and then Is_Intrinsic_Equality (Root_Prim_Op) + then + Prim_Op := Root_Prim_Op; + + -- Otherwise there are no candidate subprograms. Let the caller -- diagnose the error. else