with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
+with Nlists; use Nlists;
with Errout; use Errout;
with Lib; use Lib;
with Opt; use Opt;
procedure New_Interps (N : Node_Id);
-- Initialize collection of interpretations for the given node, which is
-- either an overloaded entity, or an operation whose arguments have
- -- multiple intepretations. Interpretations can be added to only one
+ -- multiple interpretations. Interpretations can be added to only one
-- node at a time.
function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
and then not Is_Dispatching_Operation (E)
then
return;
+
+ -- An inherited interface operation that is implemented by some
+ -- derived type does not participate in overload resolution, only
+ -- the implementation operation does.
+
+ elsif Is_Hidden (E)
+ and then Is_Subprogram (E)
+ and then Present (Abstract_Interface_Alias (E))
+ then
+ Add_One_Interp (N, Abstract_Interface_Alias (E), T);
+ return;
end if;
-- If this is the first interpretation of N, N has type Any_Type.
else
-- Overloaded prefix in indexed or selected component,
- -- or call whose name is an expresion or another call.
+ -- or call whose name is an expression or another call.
Add_Entry (Etype (N), Etype (N));
end if;
-- actuals belong to their class but are not compatible with other
-- types of their class, and in particular with other generic actuals.
-- They are however compatible with their own subtypes, and itypes
- -- with the same base are compatible as well. Similary, constrained
+ -- with the same base are compatible as well. Similarly, constrained
-- subtypes obtained from expressions of an unconstrained nominal type
-- are compatible with the base type (may lead to spurious ambiguities
-- in obscure cases ???)
and then Is_Class_Wide_Type (T1)
and then Is_Interface (Etype (T1))
and then Is_Concurrent_Type (T2)
- and then Interface_Present_In_Ancestor (
- Typ => Corresponding_Record_Type (Base_Type (T2)),
- Iface => Etype (T1))
+ and then Interface_Present_In_Ancestor
+ (Typ => Base_Type (T2),
+ Iface => Etype (T1))
then
return True;
or else
(Is_Concurrent_Type (It.Typ)
+ and then Present (Corresponding_Record_Type
+ (Etype (It.Typ)))
and then Covers (Typ, Corresponding_Record_Type
(Etype (It.Typ))))
(Typ : Entity_Id;
Iface : Entity_Id) return Boolean
is
- AI : Entity_Id;
- E : Entity_Id;
- Elmt : Elmt_Id;
+ Target_Typ : Entity_Id;
+
+ function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean;
+ -- Returns True if Typ or some ancestor of Typ implements Iface
+
+ function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is
+ E : Entity_Id;
+ AI : Entity_Id;
+ Elmt : Elmt_Id;
+
+ begin
+ if Typ = Iface then
+ return True;
+ end if;
- begin
- if Is_Access_Type (Typ) then
- E := Etype (Directly_Designated_Type (Typ));
- else
E := Typ;
- end if;
+ loop
+ if Present (Abstract_Interfaces (E))
+ and then Present (Abstract_Interfaces (E))
+ and then not Is_Empty_Elmt_List (Abstract_Interfaces (E))
+ then
+ Elmt := First_Elmt (Abstract_Interfaces (E));
+ while Present (Elmt) loop
+ AI := Node (Elmt);
- if Is_Concurrent_Type (E) then
- E := Corresponding_Record_Type (E);
- end if;
+ if AI = Iface or else Is_Ancestor (Iface, AI) then
+ return True;
+ end if;
- if Is_Class_Wide_Type (E) then
- E := Etype (E);
- end if;
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
- if E = Iface then
- return True;
- end if;
+ exit when Etype (E) = E;
- loop
- if Present (Abstract_Interfaces (E))
- and then Abstract_Interfaces (E) /= Empty_List_Or_Node -- ????
- and then not Is_Empty_Elmt_List (Abstract_Interfaces (E))
- then
- Elmt := First_Elmt (Abstract_Interfaces (E));
+ -- Check if the current type is a direct derivation of the
+ -- interface
- while Present (Elmt) loop
- AI := Node (Elmt);
+ if Etype (E) = Iface then
+ return True;
+ end if;
- if AI = Iface or else Is_Ancestor (Iface, AI) then
- return True;
- end if;
+ -- Climb to the immediate ancestor
- Next_Elmt (Elmt);
- end loop;
- end if;
+ E := Etype (E);
+ end loop;
+
+ return False;
+ end Iface_Present_In_Ancestor;
+
+ begin
+ if Is_Access_Type (Typ) then
+ Target_Typ := Etype (Directly_Designated_Type (Typ));
+ else
+ Target_Typ := Typ;
+ end if;
- exit when Etype (E) = E;
+ -- In case of concurrent types we can't use the Corresponding Record_Typ
+ -- to look for the interface because it is built by the expander (and
+ -- hence it is not always available). For this reason we traverse the
+ -- list of interfaces (available in the parent of the concurrent type)
- -- Check if the current type is a direct derivation of the
- -- interface
+ if Is_Concurrent_Type (Target_Typ) then
+ if Present (Interface_List (Parent (Target_Typ))) then
+ declare
+ AI : Node_Id;
+ begin
+ AI := First (Interface_List (Parent (Target_Typ)));
+ while Present (AI) loop
+ if Etype (AI) = Iface then
+ return True;
- if Etype (E) = Iface then
- return True;
+ elsif Present (Abstract_Interfaces (Etype (AI)))
+ and then Iface_Present_In_Ancestor (Etype (AI))
+ then
+ return True;
+ end if;
+
+ Next (AI);
+ end loop;
+ end;
end if;
- -- Climb to the immediate ancestor
+ return False;
+ end if;
- E := Etype (E);
- end loop;
+ if Is_Class_Wide_Type (Target_Typ) then
+ Target_Typ := Etype (Target_Typ);
+ end if;
- return False;
+ if Ekind (Target_Typ) = E_Incomplete_Type then
+ pragma Assert (Present (Non_Limited_View (Target_Typ)));
+ Target_Typ := Non_Limited_View (Target_Typ);
+ end if;
+
+ return Iface_Present_In_Ancestor (Target_Typ);
end Interface_Present_In_Ancestor;
---------------------
elsif Is_Class_Wide_Type (Etype (R))
and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
then
- Error_Msg_Name_1 := Chars (L);
- Error_Msg_Name_2 := Chars (Etype (Class_Wide_Type (Etype (R))));
- Error_Msg_NE ("(Ada 2005) % does not implement interface %",
+ Error_Msg_NE ("(Ada 2005) does not implement interface }",
L, Etype (Class_Wide_Type (Etype (R))));
else
projects / platform / upstream / linaro-gcc.git / commitdiff