with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
-with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Disp; use Sem_Disp;
with Sem_Util; use Sem_Util;
with Stand; use Stand;
with Sinfo; use Sinfo;
-- because otherwise we have a dummy between the two subprograms that
-- are in fact the same.
- if Present (DTC_Entity (Abstract_Interface_Alias (E)))
- and then Etype (DTC_Entity (Abstract_Interface_Alias (E)))
- /= RTE (RE_Tag)
+ if not Is_Ancestor
+ (Find_Dispatching_Type (Abstract_Interface_Alias (E)),
+ Find_Dispatching_Type (E))
then
Add_One_Interp (N, Abstract_Interface_Alias (E), T);
end if;
then
Add_Entry (Entity (Name (N)), Etype (N));
+ -- If this is an indirect call there will be no name associated
+ -- with the previous entry. To make diagnostics clearer, save
+ -- Subprogram_Type of first interpretation, so that the error will
+ -- point to the anonymous access to subprogram, not to the result
+ -- type of the call itself.
+
+ elsif (Nkind (N)) = N_Function_Call
+ and then Nkind (Name (N)) = N_Explicit_Dereference
+ and then Is_Overloaded (Name (N))
+ then
+ declare
+ I : Interp_Index;
+ It : Interp;
+ begin
+ Get_First_Interp (Name (N), I, It);
+ Add_Entry (It.Nam, Etype (N));
+ end;
+
else
-- Overloaded prefix in indexed or selected component,
-- or call whose name is an expression or another call.
and then Is_Interface (Etype (T1))
and then Is_Tagged_Type (T2)
then
- if Interface_Present_In_Ancestor (Typ => T2,
+ if Interface_Present_In_Ancestor (Typ => T2,
Iface => Etype (T1))
then
return True;
+ end if;
+
+ declare
+ E : Entity_Id;
+ Elmt : Elmt_Id;
- elsif Present (Abstract_Interfaces (T2)) then
+ begin
+ if Is_Concurrent_Type (BT2) then
+ E := Corresponding_Record_Type (BT2);
+ else
+ E := BT2;
+ end if;
-- Ada 2005 (AI-251): A class-wide abstract interface type T1
-- covers an object T2 that implements a direct derivation of T1.
+ -- Note: test for presence of E is defense against previous error.
- declare
- E : Elmt_Id := First_Elmt (Abstract_Interfaces (T2));
- begin
- while Present (E) loop
- if Is_Ancestor (Etype (T1), Node (E)) then
+ if Present (E)
+ and then Present (Abstract_Interfaces (E))
+ then
+ Elmt := First_Elmt (Abstract_Interfaces (E));
+ while Present (Elmt) loop
+ if Is_Ancestor (Etype (T1), Node (Elmt)) then
return True;
end if;
- Next_Elmt (E);
+ Next_Elmt (Elmt);
end loop;
- end;
+ end if;
-- We should also check the case in which T1 is an ancestor of
-- some implemented interface???
return False;
-
- else
- return False;
- end if;
+ end;
-- In a dispatching call the actual may be class-wide
-- If the expected type is the non-limited view of a type, the
-- expression may have the limited view.
- if Ekind (T1) = E_Incomplete_Type then
+ if Is_Incomplete_Type (T1) then
return Covers (Non_Limited_View (T1), T2);
elsif Ekind (T1) = E_Class_Wide_Type then
-- either type might have a limited view. Checks performed elsewhere
-- verify that the context type is the non-limited view.
- if Ekind (T2) = E_Incomplete_Type then
+ if Is_Incomplete_Type (T2) then
return Covers (T1, Non_Limited_View (T2));
elsif Ekind (T2) = E_Class_Wide_Type then
return False;
end if;
+ -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
+
+ elsif Ekind (T1) = E_Incomplete_Subtype then
+ return Covers (Full_View (Etype (T1)), T2);
+
+ elsif Ekind (T2) = E_Incomplete_Subtype then
+ return Covers (T1, Full_View (Etype (T2)));
+
+ -- Ada 2005 (AI-423): Coverage of formal anonymous access types
+ -- and actual anonymous access types in the context of generic
+ -- instantiation. We have the following situation:
+
+ -- generic
+ -- type Formal is private;
+ -- Formal_Obj : access Formal; -- T1
+ -- package G is ...
+
+ -- package P is
+ -- type Actual is ...
+ -- Actual_Obj : access Actual; -- T2
+ -- package Instance is new G (Formal => Actual,
+ -- Formal_Obj => Actual_Obj);
+
+ elsif Ada_Version >= Ada_05
+ and then Ekind (T1) = E_Anonymous_Access_Type
+ and then Ekind (T2) = E_Anonymous_Access_Type
+ and then Is_Generic_Type (Directly_Designated_Type (T1))
+ and then Get_Instance_Of (Directly_Designated_Type (T1)) =
+ Directly_Designated_Type (T2)
+ then
+ return True;
+
-- Otherwise it doesn't cover!
else
-- operating in an earlier mode, in which case we discard the Ada
-- 2005 entity, so that we get proper Ada 95 overload resolution.
- if Is_Ada_2005 (Nam1) then
+ if Is_Ada_2005_Only (Nam1) then
return It2;
- elsif Is_Ada_2005 (Nam2) then
+ elsif Is_Ada_2005_Only (Nam2) then
return It1;
end if;
end if;
-- list of interfaces (available in the parent of the concurrent type)
if Is_Concurrent_Type (Target_Typ) then
- if Present (Interface_List (Parent (Target_Typ))) then
+ if Present (Interface_List (Parent (Base_Type (Target_Typ)))) then
declare
AI : Node_Id;
begin
- AI := First (Interface_List (Parent (Target_Typ)));
+ AI := First (Interface_List (Parent (Base_Type (Target_Typ))));
while Present (AI) loop
if Etype (AI) = Iface then
return True;
and then Scope (It.Typ) /= Standard_Standard
then
Error_Msg_Sloc := Sloc (Parent (It.Typ));
- Error_Msg_NE (" & (inherited) declared#!", Err, It.Nam);
+ Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam);
else
Error_Msg_Sloc := Sloc (It.Nam);
- Error_Msg_NE (" & declared#!", Err, It.Nam);
+ Error_Msg_NE ("\\& declared#!", Err, It.Nam);
end if;
Get_Next_Interp (Index, It);
end if;
end Valid_Comparison_Arg;
+ ----------------------
+ -- Write_Interp_Ref --
+ ----------------------
+
+ procedure Write_Interp_Ref (Map_Ptr : Int) is
+ begin
+ Write_Str (" Node: ");
+ Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
+ Write_Str (" Index: ");
+ Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
+ Write_Str (" Next: ");
+ Write_Int (Int (Interp_Map.Table (Map_Ptr).Next));
+ Write_Eol;
+ end Write_Interp_Ref;
+
---------------------
-- Write_Overloads --
---------------------
end if;
end Write_Overloads;
- ----------------------
- -- Write_Interp_Ref --
- ----------------------
-
- procedure Write_Interp_Ref (Map_Ptr : Int) is
- begin
- Write_Str (" Node: ");
- Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
- Write_Str (" Index: ");
- Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
- Write_Str (" Next: ");
- Write_Int (Int (Interp_Map.Table (Map_Ptr).Next));
- Write_Eol;
- end Write_Interp_Ref;
-
end Sem_Type;
projects / gcc.git / commitdiff