with Atree; use Atree;
with Alloc;
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 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_Util; use Sem_Util;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Table;
with Uintp; use Uintp;
package body Sem_Type is
package All_Interp is new Table.Table (
Table_Component_Type => Interp,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => Alloc.All_Interp_Initial,
Table_Increment => Alloc.All_Interp_Increment,
Table_Name => "All_Interp");
type Interp_Ref is record
Node : Node_Id;
Index : Interp_Index;
Next : Int;
end record;
Header_Size : constant Int := 2 ** 12;
No_Entry : constant Int := -1;
Headers : array (0 .. Header_Size) of Int := (others => No_Entry);
package Interp_Map is new Table.Table (
Table_Component_Type => Interp_Ref,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => Alloc.Interp_Map_Initial,
Table_Increment => Alloc.Interp_Map_Increment,
Table_Name => "Interp_Map");
function Hash (N : Node_Id) return Int;
procedure All_Overloads;
pragma Warnings (Off, All_Overloads);
procedure New_Interps (N : Node_Id);
function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
procedure Add_One_Interp
(N : Node_Id;
E : Entity_Id;
T : Entity_Id;
Opnd_Type : Entity_Id := Empty)
is
Vis_Type : Entity_Id;
procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id);
function Is_Universal_Operation (Op : Entity_Id) return Boolean;
procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is
Index : Interp_Index;
It : Interp;
begin
Get_First_Interp (N, Index, It);
while Present (It.Nam) loop
if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure)
and then Ekind (Name) = Ekind (It.Nam))
or else (Ekind (Name) = E_Operator
and then Ekind (It.Nam) = E_Function))
and then Is_Immediately_Visible (It.Nam)
and then Type_Conformant (Name, It.Nam)
and then Base_Type (It.Typ) = Base_Type (T)
then
if Is_Universal_Operation (Name) then
exit;
elsif Nkind (N) = N_Operator_Symbol
or else (Nkind (N) = N_Expanded_Name
and then
Nkind (Selector_Name (N)) = N_Operator_Symbol)
then
exit;
elsif not In_Open_Scopes (Scope (Name))
or else Scope_Depth (Scope (Name)) <=
Scope_Depth (Scope (It.Nam))
then
if Scope (Name) = Scope (It.Nam)
and then not Is_Inherited_Operation (Name)
and then In_Instance
then
exit;
else
return;
end if;
else
All_Interp.Table (Index).Nam := Name;
return;
end if;
elsif Name = It.Nam
and then Base_Type (It.Typ) = Base_Type (T)
then
return;
else
Get_Next_Interp (Index, It);
end if;
end loop;
All_Interp.Table (All_Interp.Last) := (Name, Typ);
All_Interp.Increment_Last;
All_Interp.Table (All_Interp.Last) := No_Interp;
end Add_Entry;
function Is_Universal_Operation (Op : Entity_Id) return Boolean is
Arg : Node_Id;
begin
if Ekind (Op) /= E_Operator then
return False;
elsif Nkind (N) in N_Binary_Op then
return Present (Universal_Interpretation (Left_Opnd (N)))
and then Present (Universal_Interpretation (Right_Opnd (N)));
elsif Nkind (N) in N_Unary_Op then
return Present (Universal_Interpretation (Right_Opnd (N)));
elsif Nkind (N) = N_Function_Call then
Arg := First_Actual (N);
while Present (Arg) loop
if No (Universal_Interpretation (Arg)) then
return False;
end if;
Next_Actual (Arg);
end loop;
return True;
else
return False;
end if;
end Is_Universal_Operation;
begin
if Ekind (E) = E_Operator then
if Present (Opnd_Type) then
Vis_Type := Opnd_Type;
else
Vis_Type := Base_Type (T);
end if;
if In_Open_Scopes (Scope (Vis_Type))
or else Is_Potentially_Use_Visible (Vis_Type)
or else In_Use (Vis_Type)
or else (In_Use (Scope (Vis_Type))
and then not Is_Hidden (Vis_Type))
or else Nkind (N) = N_Expanded_Name
or else (Nkind (N) in N_Op and then E = Entity (N))
or else In_Instance
then
null;
elsif Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Expanded_Name
and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
or else Scope (Vis_Type) = System_Aux_Id)
then
null;
else
Candidate_Type := Vis_Type;
return;
end if;
elsif In_Instance
and then Is_Abstract (E)
and then not Is_Dispatching_Operation (E)
then
return;
elsif Is_Hidden (E)
and then Is_Subprogram (E)
and then Present (Abstract_Interface_Alias (E))
then
if Present (DTC_Entity (Abstract_Interface_Alias (E)))
and then Etype (DTC_Entity (Abstract_Interface_Alias (E)))
/= RTE (RE_Tag)
then
Add_One_Interp (N, Abstract_Interface_Alias (E), T);
end if;
return;
end if;
if Etype (N) = Any_Type then
if Is_Type (E) then
Set_Etype (N, T);
else
if Nkind (N) in N_Op or else Is_Entity_Name (N) then
Set_Entity (N, E);
end if;
Set_Etype (N, T);
end if;
elsif Interp_Map.Last < 0
or else
(Interp_Map.Table (Interp_Map.Last).Node /= N
and then not Is_Overloaded (N))
then
New_Interps (N);
if (Nkind (N) in N_Op or else Is_Entity_Name (N))
and then Present (Entity (N))
then
Add_Entry (Entity (N), Etype (N));
elsif (Nkind (N) = N_Function_Call
or else Nkind (N) = N_Procedure_Call_Statement)
and then (Nkind (Name (N)) = N_Operator_Symbol
or else Is_Entity_Name (Name (N)))
then
Add_Entry (Entity (Name (N)), Etype (N));
else
Add_Entry (Etype (N), Etype (N));
end if;
Add_Entry (E, T);
else
Add_Entry (E, T);
end if;
end Add_One_Interp;
procedure All_Overloads is
begin
for J in All_Interp.First .. All_Interp.Last loop
if Present (All_Interp.Table (J).Nam) then
Write_Entity_Info (All_Interp.Table (J). Nam, " ");
else
Write_Str ("No Interp");
end if;
Write_Str ("=================");
Write_Eol;
end loop;
end All_Overloads;
procedure Collect_Interps (N : Node_Id) is
Ent : constant Entity_Id := Entity (N);
H : Entity_Id;
First_Interp : Interp_Index;
begin
New_Interps (N);
First_Interp := All_Interp.Last;
Add_One_Interp (N, Ent, Etype (N));
if Nkind (N) = N_Expanded_Name then
H := Homonym (Ent);
while Present (H) loop
if Scope (H) = Scope (Entity (N)) then
Add_One_Interp (N, H, Etype (H));
end if;
H := Homonym (H);
end loop;
else
H := Current_Entity (Ent);
while Present (H) loop
exit when (not Is_Overloadable (H))
and then Is_Immediately_Visible (H);
if Is_Immediately_Visible (H)
and then H /= Ent
then
for J in First_Interp .. All_Interp.Last - 1 loop
if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
exit;
elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
if Scope (H) = Scope (Ent)
and then In_Instance
and then not Is_Inherited_Operation (H)
then
All_Interp.Table (All_Interp.Last) := (H, Etype (H));
All_Interp.Increment_Last;
All_Interp.Table (All_Interp.Last) := No_Interp;
goto Next_Homograph;
elsif Scope (H) /= Standard_Standard then
goto Next_Homograph;
end if;
end if;
end loop;
Add_One_Interp (N, H, Etype (H));
if Debug_Flag_E then
Write_Str ("Add overloaded Interpretation ");
Write_Int (Int (H));
Write_Eol;
end if;
end if;
<<Next_Homograph>>
H := Homonym (H);
end loop;
H := Current_Entity (Ent);
while Present (H) loop
if Is_Potentially_Use_Visible (H)
and then H /= Ent
and then Is_Overloadable (H)
then
for J in First_Interp .. All_Interp.Last - 1 loop
if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
exit;
elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
goto Next_Use_Homograph;
end if;
end loop;
Add_One_Interp (N, H, Etype (H));
end if;
<<Next_Use_Homograph>>
H := Homonym (H);
end loop;
end if;
if All_Interp.Last = First_Interp + 1 then
Set_Is_Overloaded (N, False);
end if;
end Collect_Interps;
function Covers (T1, T2 : Entity_Id) return Boolean is
BT1 : Entity_Id;
BT2 : Entity_Id;
function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean;
function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is
begin
return
Is_Private_Type (Typ1)
and then
((Present (Full_View (Typ1))
and then Covers (Full_View (Typ1), Typ2))
or else Base_Type (Typ1) = Typ2
or else Base_Type (Typ2) = Typ1);
end Full_View_Covers;
begin
if No (T1) or else No (T2) then
if Total_Errors_Detected /= 0 then
return True;
else
raise Program_Error;
end if;
else
BT1 := Base_Type (T1);
BT2 := Base_Type (T2);
end if;
if T1 = T2 then
return True;
elsif BT1 = BT2
or else BT1 = T2
or else BT2 = T1
then
if not Is_Generic_Actual_Type (T1) then
return True;
else
return (not Is_Generic_Actual_Type (T2)
or else Is_Itype (T1)
or else Is_Itype (T2)
or else Is_Constr_Subt_For_U_Nominal (T1)
or else Is_Constr_Subt_For_U_Nominal (T2)
or else Scope (T1) /= Scope (T2));
end if;
elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
or else (T2 = Universal_Real and then Is_Real_Type (T1))
or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
or else (T2 = Any_String and then Is_String_Type (T1))
or else (T2 = Any_Character and then Is_Character_Type (T1))
or else (T2 = Any_Access and then Is_Access_Type (T1))
then
return True;
elsif Is_Class_Wide_Type (T1)
and then Is_Ancestor (Root_Type (T1), T2)
then
return True;
elsif Is_Class_Wide_Type (T1)
and then Is_Class_Wide_Type (T2)
and then Base_Type (Etype (T1)) = Base_Type (Etype (T2))
then
return True;
elsif Ada_Version >= Ada_05
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 => Base_Type (T2),
Iface => Etype (T1))
then
return True;
elsif Ada_Version >= Ada_05
and then Is_Class_Wide_Type (T1)
and then Is_Interface (Etype (T1))
and then Is_Tagged_Type (T2)
then
if Interface_Present_In_Ancestor (Typ => T2,
Iface => Etype (T1))
then
return True;
elsif Present (Abstract_Interfaces (T2)) then
declare
E : Elmt_Id := First_Elmt (Abstract_Interfaces (T2));
begin
while Present (E) loop
if Is_Ancestor (Etype (T1), Node (E)) then
return True;
end if;
Next_Elmt (E);
end loop;
end;
return False;
else
return False;
end if;
elsif Is_Class_Wide_Type (T2)
and then Base_Type (Root_Type (T2)) = Base_Type (T1)
then
return True;
elsif (T1 = Any_Integer and then Is_Integer_Type (T2))
or else (T1 = Any_Boolean and then Is_Boolean_Type (T2))
or else (T1 = Any_Real and then Is_Real_Type (T2))
or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
or else (T1 = Any_Discrete and then Is_Discrete_Type (T2))
then
return True;
elsif T2 = Any_Composite
and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
then
return True;
elsif Ekind (T1) = E_Anonymous_Access_Type
and then Is_Access_Type (T2)
and then Covers (Designated_Type (T1), Designated_Type (T2))
then
return True;
elsif (Ekind (BT1) = E_Access_Subprogram_Type
or else
Ekind (BT1) = E_Access_Protected_Subprogram_Type)
and then Is_Access_Type (T2)
and then (not Comes_From_Source (T1)
or else not Comes_From_Source (T2))
and then (Is_Overloadable (Designated_Type (T2))
or else
Ekind (Designated_Type (T2)) = E_Subprogram_Type)
and then
Type_Conformant (Designated_Type (T1), Designated_Type (T2))
and then
Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
then
return True;
elsif (Ekind (BT1) = E_Anonymous_Access_Subprogram_Type
or else
Ekind (BT1)
= E_Anonymous_Access_Protected_Subprogram_Type)
and then Is_Access_Type (T2)
and then (not Comes_From_Source (T1)
or else not Comes_From_Source (T2))
and then (Is_Overloadable (Designated_Type (T2))
or else
Ekind (Designated_Type (T2)) = E_Subprogram_Type)
and then
Type_Conformant (Designated_Type (T1), Designated_Type (T2))
and then
Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
then
return True;
elsif Is_Record_Type (T1)
and then (Is_Remote_Call_Interface (T1)
or else Is_Remote_Types (T1))
and then Present (Corresponding_Remote_Type (T1))
then
return Covers (Corresponding_Remote_Type (T1), T2);
elsif Is_Record_Type (T2)
and then (Is_Remote_Call_Interface (T2)
or else Is_Remote_Types (T2))
and then Present (Corresponding_Remote_Type (T2))
then
return Covers (Corresponding_Remote_Type (T2), T1);
elsif Ekind (T2) = E_Access_Attribute_Type
and then (Ekind (BT1) = E_General_Access_Type
or else Ekind (BT1) = E_Access_Type)
and then Covers (Designated_Type (T1), Designated_Type (T2))
then
if Is_Remote_Access_To_Class_Wide_Type (BT1) then
Set_Has_RACW (Current_Sem_Unit);
end if;
return True;
elsif Ekind (T2) = E_Allocator_Type
and then Is_Access_Type (T1)
then
return Covers (Designated_Type (T1), Designated_Type (T2))
or else
(From_With_Type (Designated_Type (T1))
and then Covers (Designated_Type (T2), Designated_Type (T1)));
elsif T2 = Any_Modular
and then Is_Modular_Integer_Type (T1)
then
return True;
elsif Base_Type (T2) = Any_Type then
return True;
elsif Is_Array_Type (T2)
and then Is_Packed (T2)
and then T1 = Packed_Array_Type (T2)
then
return True;
elsif Is_Array_Type (T1)
and then Is_Packed (T1)
and then T2 = Packed_Array_Type (T1)
then
return True;
elsif In_Instance
and then
(Full_View_Covers (T1, T2)
or else Full_View_Covers (T2, T1))
then
return True;
elsif Is_Type (T2)
and then Is_Generic_Actual_Type (T2)
and then Full_View_Covers (T1, T2)
then
return True;
elsif Is_Type (T1)
and then Is_Generic_Actual_Type (T1)
and then Full_View_Covers (T2, T1)
then
return True;
elsif In_Inlined_Body
and then (Underlying_Type (T1) = Underlying_Type (T2)
or else (Is_Access_Type (T1)
and then Is_Access_Type (T2)
and then
Designated_Type (T1) = Designated_Type (T2))
or else (T1 = Any_Access
and then Is_Access_Type (Underlying_Type (T2)))
or else (T2 = Any_Composite
and then
Is_Composite_Type (Underlying_Type (T1))))
then
return True;
elsif From_With_Type (T1) then
if Ekind (T1) = E_Incomplete_Type then
return Covers (Non_Limited_View (T1), T2);
elsif Ekind (T1) = E_Class_Wide_Type then
return
Covers (Class_Wide_Type (Non_Limited_View (Etype (T1))), T2);
else
return False;
end if;
elsif From_With_Type (T2) then
if Ekind (T2) = E_Incomplete_Type then
return Covers (T1, Non_Limited_View (T2));
elsif Ekind (T2) = E_Class_Wide_Type then
return
Covers (T1, Class_Wide_Type (Non_Limited_View (Etype (T2))));
else
return False;
end if;
else
return False;
end if;
end Covers;
function Disambiguate
(N : Node_Id;
I1, I2 : Interp_Index;
Typ : Entity_Id)
return Interp
is
I : Interp_Index;
It : Interp;
It1, It2 : Interp;
Nam1, Nam2 : Entity_Id;
Predef_Subp : Entity_Id;
User_Subp : Entity_Id;
function Inherited_From_Actual (S : Entity_Id) return Boolean;
function In_Generic_Actual (Exp : Node_Id) return Boolean;
function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
function Matches (Actual, Formal : Node_Id) return Boolean;
function Standard_Operator return Boolean;
function Remove_Conversions return Interp;
function In_Generic_Actual (Exp : Node_Id) return Boolean is
Par : constant Node_Id := Parent (Exp);
begin
if No (Par) then
return False;
elsif Nkind (Par) in N_Declaration then
if Nkind (Par) = N_Object_Declaration
or else Nkind (Par) = N_Object_Renaming_Declaration
then
return Present (Corresponding_Generic_Association (Par));
else
return False;
end if;
elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then
return False;
else
return In_Generic_Actual (Parent (Par));
end if;
end In_Generic_Actual;
function Inherited_From_Actual (S : Entity_Id) return Boolean is
Par : constant Node_Id := Parent (S);
begin
if Nkind (Par) /= N_Full_Type_Declaration
or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition
then
return False;
else
return Is_Entity_Name (Subtype_Indication (Type_Definition (Par)))
and then
Is_Generic_Actual_Type (
Entity (Subtype_Indication (Type_Definition (Par))));
end if;
end Inherited_From_Actual;
function Is_Actual_Subprogram (S : Entity_Id) return Boolean is
begin
return In_Open_Scopes (Scope (S))
and then
(Is_Generic_Instance (Scope (S))
or else Is_Wrapper_Package (Scope (S)));
end Is_Actual_Subprogram;
function Matches (Actual, Formal : Node_Id) return Boolean is
T1 : constant Entity_Id := Etype (Actual);
T2 : constant Entity_Id := Etype (Formal);
begin
return T1 = T2
or else
(Is_Numeric_Type (T2)
and then
(T1 = Universal_Real or else T1 = Universal_Integer));
end Matches;
function Remove_Conversions return Interp is
I : Interp_Index;
It : Interp;
It1 : Interp;
F1 : Entity_Id;
Act1 : Node_Id;
Act2 : Node_Id;
function Has_Abstract_Interpretation (N : Node_Id) return Boolean;
function Has_Abstract_Interpretation (N : Node_Id) return Boolean is
E : Entity_Id;
begin
E := Current_Entity (N);
while Present (E) loop
if Is_Abstract (E)
and then Is_Numeric_Type (Etype (E))
then
return True;
else
E := Homonym (E);
end if;
end loop;
return False;
end Has_Abstract_Interpretation;
begin
It1 := No_Interp;
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
if not Is_Overloadable (It.Nam) then
return No_Interp;
end if;
F1 := First_Formal (It.Nam);
if No (F1) then
return It1;
else
if Nkind (N) = N_Function_Call
or else Nkind (N) = N_Procedure_Call_Statement
then
Act1 := First_Actual (N);
if Present (Act1) then
Act2 := Next_Actual (Act1);
else
Act2 := Empty;
end if;
elsif Nkind (N) in N_Unary_Op then
Act1 := Right_Opnd (N);
Act2 := Empty;
elsif Nkind (N) in N_Binary_Op then
Act1 := Left_Opnd (N);
Act2 := Right_Opnd (N);
else
return It1;
end if;
if Nkind (Act1) in N_Op
and then Is_Overloaded (Act1)
and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
or else Nkind (Right_Opnd (Act1)) = N_Real_Literal)
and then Has_Compatible_Type (Act1, Standard_Boolean)
and then Etype (F1) = Standard_Boolean
then
if It1 /= No_Interp then
if It = Disambiguate.It1
or else It = Disambiguate.It2
then
if It1 = Disambiguate.It1
or else It1 = Disambiguate.It2
then
return No_Interp;
else
It1 := It;
end if;
end if;
elsif Present (Act2)
and then Nkind (Act2) in N_Op
and then Is_Overloaded (Act2)
and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
or else
Nkind (Right_Opnd (Act1)) = N_Real_Literal)
and then Has_Compatible_Type (Act2, Standard_Boolean)
then
goto Next_Interp;
else
It1 := It;
end if;
elsif Nkind (Act1) in N_Op
and then Is_Overloaded (Act1)
and then Present (Universal_Interpretation (Act1))
and then Is_Numeric_Type (Etype (F1))
and then Ada_Version >= Ada_05
and then Has_Abstract_Interpretation (Act1)
then
if It = Disambiguate.It1 then
return Disambiguate.It2;
elsif It = Disambiguate.It2 then
return Disambiguate.It1;
end if;
end if;
end if;
<<Next_Interp>>
Get_Next_Interp (I, It);
end loop;
if Serious_Errors_Detected > 0 then
declare
Formal : Entity_Id;
begin
Formal := First_Formal (Nam1);
while Present (Formal) loop
if Etype (Formal) = Any_Type then
return Disambiguate.It2;
end if;
Next_Formal (Formal);
end loop;
Formal := First_Formal (Nam2);
while Present (Formal) loop
if Etype (Formal) = Any_Type then
return Disambiguate.It1;
end if;
Next_Formal (Formal);
end loop;
end;
end if;
return It1;
end Remove_Conversions;
function Standard_Operator return Boolean is
Nam : Node_Id;
begin
if Nkind (N) in N_Op then
return True;
elsif Nkind (N) = N_Function_Call then
Nam := Name (N);
if Nkind (Nam) /= N_Expanded_Name then
return True;
else
return Entity (Prefix (Nam)) = Standard_Standard;
end if;
else
return False;
end if;
end Standard_Operator;
begin
Get_First_Interp (N, I, It);
while I /= I1 loop
Get_Next_Interp (I, It);
end loop;
It1 := It;
Nam1 := It.Nam;
while I /= I2 loop
Get_Next_Interp (I, It);
end loop;
It2 := It;
Nam2 := It.Nam;
if Ada_Version < Ada_05 then
if Is_Ada_2005 (Nam1) then
return It2;
elsif Is_Ada_2005 (Nam2) then
return It1;
end if;
end if;
if Chars (Nam1) in Any_Operator_Name
and then Standard_Operator
then
if Typ = Universal_Integer
or else Typ = Universal_Real
or else Typ = Any_Integer
or else Typ = Any_Discrete
or else Typ = Any_Real
or else Typ = Any_Type
then
declare
Candidate : Interp := No_Interp;
begin
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
if (Covers (Typ, It.Typ)
or else Typ = Any_Type)
and then
(It.Typ = Universal_Integer
or else It.Typ = Universal_Real)
then
return It;
elsif Covers (Typ, It.Typ)
and then Scope (It.Typ) = Standard_Standard
and then Scope (It.Nam) = Standard_Standard
and then Is_Numeric_Type (It.Typ)
then
Candidate := It;
end if;
Get_Next_Interp (I, It);
end loop;
if Candidate /= No_Interp then
return Candidate;
end if;
end;
elsif Chars (Nam1) /= Name_Op_Not
and then (Typ = Standard_Boolean or else Typ = Any_Boolean)
then
declare
Arg1, Arg2 : Node_Id;
begin
if Nkind (N) in N_Op then
Arg1 := Left_Opnd (N);
Arg2 := Right_Opnd (N);
elsif Is_Entity_Name (N)
or else Nkind (N) = N_Operator_Symbol
then
Arg1 := First_Entity (Entity (N));
Arg2 := Next_Entity (Arg1);
else
Arg1 := First_Actual (N);
Arg2 := Next_Actual (Arg1);
end if;
if Present (Arg2)
and then Present (Universal_Interpretation (Arg1))
and then Universal_Interpretation (Arg2) =
Universal_Interpretation (Arg1)
then
Get_First_Interp (N, I, It);
while Scope (It.Nam) /= Standard_Standard loop
Get_Next_Interp (I, It);
end loop;
return It;
end if;
end;
end if;
end if;
if Ekind (Nam1) = E_Operator then
Predef_Subp := Nam1;
User_Subp := Nam2;
elsif Ekind (Nam2) = E_Operator then
Predef_Subp := Nam2;
User_Subp := Nam1;
elsif Nkind (N) = N_Range then
return It1;
else
if Nkind (N) = N_Procedure_Call_Statement
and then Nkind (Parent (N)) = N_Entry_Call_Alternative
and then N = Entry_Call_Statement (Parent (N))
then
if Ekind (Nam2) = E_Entry then
return It2;
elsif Ekind (Nam1) = E_Entry then
return It1;
else
return No_Interp;
end if;
elsif In_Instance
and then not In_Generic_Actual (N)
then
if Nkind (N) = N_Function_Call
or else Nkind (N) = N_Procedure_Call_Statement
then
declare
Actual : Node_Id;
Formal : Entity_Id;
Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1);
Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2);
begin
if Is_Act1 and then not Is_Act2 then
return It1;
elsif Is_Act2 and then not Is_Act1 then
return It2;
elsif Inherited_From_Actual (Nam1)
and then Comes_From_Source (Nam2)
then
return It2;
elsif Inherited_From_Actual (Nam2)
and then Comes_From_Source (Nam1)
then
return It1;
end if;
Actual := First_Actual (N);
Formal := First_Formal (Nam1);
while Present (Actual) loop
if Etype (Actual) /= Etype (Formal) then
return It2;
end if;
Next_Actual (Actual);
Next_Formal (Formal);
end loop;
return It1;
end;
elsif Nkind (N) in N_Binary_Op then
if Matches (Left_Opnd (N), First_Formal (Nam1))
and then
Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
then
return It1;
else
return It2;
end if;
elsif Nkind (N) in N_Unary_Op then
if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
return It1;
else
return It2;
end if;
else
return Remove_Conversions;
end if;
else
return Remove_Conversions;
end if;
end if;
if Chars (User_Subp) = Name_Op_Concat
and then Ekind (User_Subp) = E_Operator
and then Is_String_Type (Etype (First_Formal (User_Subp)))
then
return No_Interp;
elsif (Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Expanded_Name
and then (Chars (Predef_Subp) /= Name_Op_Expon
or else Hides_Op (User_Subp, Predef_Subp))
and then Scope (User_Subp) = Entity (Prefix (Name (N))))
or else Hides_Op (User_Subp, Predef_Subp)
then
if It1.Nam = User_Subp then
return It1;
else
return It2;
end if;
else
if (In_Open_Scopes (Scope (User_Subp))
or else Is_Potentially_Use_Visible (User_Subp))
and then not In_Instance
then
if Is_Fixed_Point_Type (Typ)
and then (Chars (Nam1) = Name_Op_Multiply
or else Chars (Nam1) = Name_Op_Divide)
and then Ada_Version = Ada_83
then
if It2.Nam = Predef_Subp then
return It1;
else
return It2;
end if;
elsif (Chars (Nam1) = Name_Op_Eq
or else
Chars (Nam1) = Name_Op_Ne)
and then Ada_Version >= Ada_05
and then Etype (User_Subp) = Standard_Boolean
then
declare
Opnd : Node_Id;
begin
if Nkind (N) = N_Function_Call then
Opnd := First_Actual (N);
else
Opnd := Left_Opnd (N);
end if;
if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type
and then
List_Containing (Parent (Designated_Type (Etype (Opnd))))
= List_Containing (Unit_Declaration_Node (User_Subp))
then
if It2.Nam = Predef_Subp then
return It1;
else
return It2;
end if;
else
return No_Interp;
end if;
end;
else
return No_Interp;
end if;
elsif It1.Nam = Predef_Subp then
return It1;
else
return It2;
end if;
end if;
end Disambiguate;
procedure End_Interp_List is
begin
All_Interp.Table (All_Interp.Last) := No_Interp;
All_Interp.Increment_Last;
end End_Interp_List;
function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
begin
if Ekind (Old_S) = Ekind (New_S)
or else (Ekind (New_S) = E_Function
and then Ekind (Old_S) = E_Enumeration_Literal)
then
return Type_Conformant (New_S, Old_S);
elsif Ekind (New_S) = E_Function
and then Ekind (Old_S) = E_Operator
then
return Operator_Matches_Spec (Old_S, New_S);
elsif Ekind (New_S) = E_Procedure
and then Is_Entry (Old_S)
then
return Type_Conformant (New_S, Old_S);
else
return False;
end if;
end Entity_Matches_Spec;
function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
T : constant Entity_Id := Etype (L);
I : Interp_Index;
It : Interp;
TR : Entity_Id := Any_Type;
begin
if Is_Overloaded (R) then
Get_First_Interp (R, I, It);
while Present (It.Typ) loop
if Covers (T, It.Typ) or else Covers (It.Typ, T) then
if TR /= Any_Type then
if (T = Universal_Integer or else T = Universal_Real)
and then It.Typ = T
then
TR := It.Typ;
end if;
else
TR := It.Typ;
end if;
end if;
Get_Next_Interp (I, It);
end loop;
Set_Etype (R, TR);
else
null;
end if;
if Etype (R) = Universal_Fixed then
return T;
elsif T = Universal_Fixed then
return Etype (R);
elsif Ada_Version >= Ada_05
and then Ekind (Etype (L)) = E_Anonymous_Access_Type
and then Is_Access_Type (Etype (R))
and then Ekind (Etype (R)) /= E_Access_Type
then
return Etype (L);
elsif Ada_Version >= Ada_05
and then Ekind (Etype (R)) = E_Anonymous_Access_Type
and then Is_Access_Type (Etype (L))
and then Ekind (Etype (L)) /= E_Access_Type
then
return Etype (R);
else
return Specific_Type (T, Etype (R));
end if;
end Find_Unique_Type;
procedure Get_First_Interp
(N : Node_Id;
I : out Interp_Index;
It : out Interp)
is
Map_Ptr : Int;
Int_Ind : Interp_Index;
O_N : Node_Id;
begin
if Nkind (N) = N_Selected_Component
and then Is_Overloaded (Selector_Name (N))
then
O_N := Selector_Name (N);
else
O_N := N;
end if;
Map_Ptr := Headers (Hash (O_N));
while Present (Interp_Map.Table (Map_Ptr).Node) loop
if Interp_Map.Table (Map_Ptr).Node = O_N then
Int_Ind := Interp_Map.Table (Map_Ptr).Index;
It := All_Interp.Table (Int_Ind);
I := Int_Ind;
return;
else
Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
end if;
end loop;
raise Program_Error;
end Get_First_Interp;
procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
begin
I := I + 1;
It := All_Interp.Table (I);
end Get_Next_Interp;
function Has_Compatible_Type
(N : Node_Id;
Typ : Entity_Id)
return Boolean
is
I : Interp_Index;
It : Interp;
begin
if N = Error then
return False;
end if;
if Nkind (N) = N_Subtype_Indication
or else not Is_Overloaded (N)
then
return
Covers (Typ, Etype (N))
or else
(Is_Concurrent_Type (Etype (N))
and then Present (Corresponding_Record_Type (Etype (N)))
and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
or else
(not Is_Tagged_Type (Typ)
and then Ekind (Typ) /= E_Anonymous_Access_Type
and then Covers (Etype (N), Typ));
else
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
if (Covers (Typ, It.Typ)
and then
(Scope (It.Nam) /= Standard_Standard
or else not Is_Invisible_Operator (N, Base_Type (Typ))))
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))))
or else (not Is_Tagged_Type (Typ)
and then Ekind (Typ) /= E_Anonymous_Access_Type
and then Covers (It.Typ, Typ))
then
return True;
end if;
Get_Next_Interp (I, It);
end loop;
return False;
end if;
end Has_Compatible_Type;
function Hash (N : Node_Id) return Int is
begin
return ((Int (N) / 2 ** 5) mod Header_Size);
end Hash;
function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
begin
return Operator_Matches_Spec (Op, F)
and then (In_Open_Scopes (Scope (F))
or else Scope (F) = Scope (Btyp)
or else (not In_Open_Scopes (Scope (Btyp))
and then not In_Use (Btyp)
and then not In_Use (Scope (Btyp))));
end Hides_Op;
procedure Init_Interp_Tables is
begin
All_Interp.Init;
Interp_Map.Init;
Headers := (others => No_Entry);
end Init_Interp_Tables;
function Interface_Present_In_Ancestor
(Typ : Entity_Id;
Iface : Entity_Id) return Boolean
is
Target_Typ : Entity_Id;
function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean;
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;
if Present (Full_View (Typ))
and then not Is_Concurrent_Type (Full_View (Typ))
then
E := Full_View (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 AI = Iface or else Is_Ancestor (Iface, AI) then
return True;
end if;
Next_Elmt (Elmt);
end loop;
end if;
exit when Etype (E) = E
or else (Present (Full_View (Etype (E)))
and then Full_View (Etype (E)) = E);
if Etype (E) = Iface then
return True;
end if;
if Present (Full_View (Etype (E))) then
E := Full_View (Etype (E));
else
E := Etype (E);
end if;
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;
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;
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;
return False;
end if;
if Is_Class_Wide_Type (Target_Typ) then
Target_Typ := Etype (Target_Typ);
end if;
if Ekind (Target_Typ) = E_Incomplete_Type then
pragma Assert (Present (Non_Limited_View (Target_Typ)));
Target_Typ := Non_Limited_View (Target_Typ);
if Ekind (Target_Typ) = E_Incomplete_Type then
return False;
end if;
end if;
return Iface_Present_In_Ancestor (Target_Typ);
end Interface_Present_In_Ancestor;
function Intersect_Types (L, R : Node_Id) return Entity_Id is
Index : Interp_Index;
It : Interp;
Typ : Entity_Id;
function Check_Right_Argument (T : Entity_Id) return Entity_Id;
function Check_Right_Argument (T : Entity_Id) return Entity_Id is
Index : Interp_Index;
It : Interp;
T2 : Entity_Id;
begin
if not Is_Overloaded (R) then
return Specific_Type (T, Etype (R));
else
Get_First_Interp (R, Index, It);
loop
T2 := Specific_Type (T, It.Typ);
if T2 /= Any_Type then
return T2;
end if;
Get_Next_Interp (Index, It);
exit when No (It.Typ);
end loop;
return Any_Type;
end if;
end Check_Right_Argument;
begin
if Etype (L) = Any_Type or else Etype (R) = Any_Type then
return Any_Type;
end if;
if not Is_Overloaded (L) then
Typ := Check_Right_Argument (Etype (L));
else
Typ := Any_Type;
Get_First_Interp (L, Index, It);
while Present (It.Typ) loop
Typ := Check_Right_Argument (It.Typ);
exit when Typ /= Any_Type;
Get_Next_Interp (Index, It);
end loop;
end if;
if Typ = Any_Type then
if Nkind (Parent (L)) in N_Op then
Error_Msg_N ("incompatible types for operator", Parent (L));
elsif Nkind (Parent (L)) = N_Range then
Error_Msg_N ("incompatible types given in constraint", Parent (L));
elsif Is_Class_Wide_Type (Etype (R))
and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
then
Error_Msg_NE ("(Ada 2005) does not implement interface }",
L, Etype (Class_Wide_Type (Etype (R))));
else
Error_Msg_N ("incompatible types", Parent (L));
end if;
end if;
return Typ;
end Intersect_Types;
function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
Par : Entity_Id;
begin
if Base_Type (T1) = Base_Type (T2) then
return True;
elsif Is_Private_Type (T1)
and then Present (Full_View (T1))
and then Base_Type (T2) = Base_Type (Full_View (T1))
then
return True;
else
Par := Etype (T2);
loop
if Error_Posted (Par) then
return False;
elsif Base_Type (T1) = Base_Type (Par)
or else (Is_Private_Type (T1)
and then Present (Full_View (T1))
and then Base_Type (Par) = Base_Type (Full_View (T1)))
then
return True;
elsif Is_Private_Type (Par)
and then Present (Full_View (Par))
and then Full_View (Par) = Base_Type (T1)
then
return True;
elsif Etype (Par) /= Par then
Par := Etype (Par);
else
return False;
end if;
end loop;
end if;
end Is_Ancestor;
function Is_Invisible_Operator
(N : Node_Id;
T : Entity_Id)
return Boolean
is
Orig_Node : constant Node_Id := Original_Node (N);
begin
if Nkind (N) not in N_Op then
return False;
elsif not Comes_From_Source (N) then
return False;
elsif No (Universal_Interpretation (Right_Opnd (N))) then
return False;
elsif Nkind (N) in N_Binary_Op
and then No (Universal_Interpretation (Left_Opnd (N)))
then
return False;
else
return Is_Numeric_Type (T)
and then not In_Open_Scopes (Scope (T))
and then not Is_Potentially_Use_Visible (T)
and then not In_Use (T)
and then not In_Use (Scope (T))
and then
(Nkind (Orig_Node) /= N_Function_Call
or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
and then not In_Instance;
end if;
end Is_Invisible_Operator;
function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
S : Entity_Id;
begin
S := Ancestor_Subtype (T1);
while Present (S) loop
if S = T2 then
return True;
else
S := Ancestor_Subtype (S);
end if;
end loop;
return False;
end Is_Subtype_Of;
procedure List_Interps (Nam : Node_Id; Err : Node_Id) is
Index : Interp_Index;
It : Interp;
begin
Get_First_Interp (Nam, Index, It);
while Present (It.Nam) loop
if Scope (It.Nam) = Standard_Standard
and then Scope (It.Typ) /= Standard_Standard
then
Error_Msg_Sloc := Sloc (Parent (It.Typ));
Error_Msg_NE (" & (inherited) declared#!", Err, It.Nam);
else
Error_Msg_Sloc := Sloc (It.Nam);
Error_Msg_NE (" & declared#!", Err, It.Nam);
end if;
Get_Next_Interp (Index, It);
end loop;
end List_Interps;
procedure New_Interps (N : Node_Id) is
Map_Ptr : Int;
begin
All_Interp.Increment_Last;
All_Interp.Table (All_Interp.Last) := No_Interp;
Map_Ptr := Headers (Hash (N));
if Map_Ptr = No_Entry then
Interp_Map.Increment_Last;
Headers (Hash (N)) := Interp_Map.Last;
else
loop
if Interp_Map.Table (Map_Ptr).Node = N then
Interp_Map.Table (Map_Ptr).Node := N;
Interp_Map.Table (Map_Ptr).Index := All_Interp.Last;
Set_Is_Overloaded (N, True);
return;
else
exit when Interp_Map.Table (Map_Ptr).Next = No_Entry;
Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
end if;
end loop;
Interp_Map.Increment_Last;
Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last;
end if;
Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry);
Set_Is_Overloaded (N, True);
end New_Interps;
function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
Op_Name : constant Name_Id := Chars (Op);
T : constant Entity_Id := Etype (New_S);
New_F : Entity_Id;
Old_F : Entity_Id;
Num : Int;
T1 : Entity_Id;
T2 : Entity_Id;
begin
New_F := First_Formal (New_S);
Old_F := First_Formal (Op);
Num := 0;
while Present (New_F) and then Present (Old_F) loop
Num := Num + 1;
Next_Formal (New_F);
Next_Formal (Old_F);
end loop;
if Present (Old_F) or else Present (New_F) then
return False;
elsif Num = 1 then
T1 := Etype (First_Formal (New_S));
if Op_Name = Name_Op_Subtract
or else Op_Name = Name_Op_Add
or else Op_Name = Name_Op_Abs
then
return Base_Type (T1) = Base_Type (T)
and then Is_Numeric_Type (T);
elsif Op_Name = Name_Op_Not then
return Base_Type (T1) = Base_Type (T)
and then Valid_Boolean_Arg (Base_Type (T));
else
return False;
end if;
else
T1 := Etype (First_Formal (New_S));
T2 := Etype (Next_Formal (First_Formal (New_S)));
if Op_Name = Name_Op_And or else Op_Name = Name_Op_Or
or else Op_Name = Name_Op_Xor
then
return Base_Type (T1) = Base_Type (T2)
and then Base_Type (T1) = Base_Type (T)
and then Valid_Boolean_Arg (Base_Type (T));
elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then
return Base_Type (T1) = Base_Type (T2)
and then not Is_Limited_Type (T1)
and then Is_Boolean_Type (T);
elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le
or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge
then
return Base_Type (T1) = Base_Type (T2)
and then Valid_Comparison_Arg (T1)
and then Is_Boolean_Type (T);
elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
return Base_Type (T1) = Base_Type (T2)
and then Base_Type (T1) = Base_Type (T)
and then Is_Numeric_Type (T);
elsif Op_Name = Name_Op_Divide then
return (Base_Type (T1) = Base_Type (T2)
and then Base_Type (T1) = Base_Type (T)
and then Is_Numeric_Type (T)
and then (not Is_Fixed_Point_Type (T)
or else Ada_Version = Ada_83))
or else (Base_Type (T1) = Base_Type (T)
and then Base_Type (T2) = Base_Type (Standard_Integer)
and then Is_Fixed_Point_Type (T))
or else (Is_Integer_Type (T2)
and then Is_Floating_Point_Type (T1)
and then Base_Type (T1) = Base_Type (T));
elsif Op_Name = Name_Op_Multiply then
return (Base_Type (T1) = Base_Type (T2)
and then Base_Type (T1) = Base_Type (T)
and then Is_Numeric_Type (T)
and then (not Is_Fixed_Point_Type (T)
or else Ada_Version = Ada_83))
or else (Base_Type (T1) = Base_Type (T)
and then Base_Type (T2) = Base_Type (Standard_Integer)
and then Is_Fixed_Point_Type (T))
or else (Base_Type (T2) = Base_Type (T)
and then Base_Type (T1) = Base_Type (Standard_Integer)
and then Is_Fixed_Point_Type (T))
or else (Is_Integer_Type (T2)
and then Is_Floating_Point_Type (T1)
and then Base_Type (T1) = Base_Type (T))
or else (Is_Integer_Type (T1)
and then Is_Floating_Point_Type (T2)
and then Base_Type (T2) = Base_Type (T));
elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
return Base_Type (T1) = Base_Type (T2)
and then Base_Type (T1) = Base_Type (T)
and then Is_Integer_Type (T);
elsif Op_Name = Name_Op_Expon then
return Base_Type (T1) = Base_Type (T)
and then Is_Numeric_Type (T)
and then Base_Type (T2) = Base_Type (Standard_Integer);
elsif Op_Name = Name_Op_Concat then
return Is_Array_Type (T)
and then (Base_Type (T) = Base_Type (Etype (Op)))
and then (Base_Type (T1) = Base_Type (T)
or else
Base_Type (T1) = Base_Type (Component_Type (T)))
and then (Base_Type (T2) = Base_Type (T)
or else
Base_Type (T2) = Base_Type (Component_Type (T)));
else
return False;
end if;
end if;
end Operator_Matches_Spec;
procedure Remove_Interp (I : in out Interp_Index) is
II : Interp_Index;
begin
II := I + 1;
while Present (All_Interp.Table (II).Typ) loop
II := II + 1;
end loop;
for J in I + 1 .. II loop
All_Interp.Table (J - 1) := All_Interp.Table (J);
end loop;
I := I - 1;
end Remove_Interp;
procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
Map_Ptr : Int;
O_N : Node_Id := Old_N;
begin
if Is_Overloaded (Old_N) then
if Nkind (Old_N) = N_Selected_Component
and then Is_Overloaded (Selector_Name (Old_N))
then
O_N := Selector_Name (Old_N);
end if;
Map_Ptr := Headers (Hash (O_N));
while Interp_Map.Table (Map_Ptr).Node /= O_N loop
Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
pragma Assert (Map_Ptr /= No_Entry);
end loop;
New_Interps (New_N);
Interp_Map.Table (Interp_Map.Last).Index :=
Interp_Map.Table (Map_Ptr).Index;
end if;
end Save_Interps;
function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
B1 : constant Entity_Id := Base_Type (T1);
B2 : constant Entity_Id := Base_Type (T2);
function Is_Remote_Access (T : Entity_Id) return Boolean;
function Is_Remote_Access (T : Entity_Id) return Boolean is
begin
return Is_Record_Type (T)
and then (Is_Remote_Call_Interface (T)
or else Is_Remote_Types (T))
and then Present (Corresponding_Remote_Type (T))
and then Is_Access_Type (Corresponding_Remote_Type (T));
end Is_Remote_Access;
begin
if T1 = Any_Type or else T2 = Any_Type then
return Any_Type;
end if;
if B1 = B2 then
return B1;
elsif False
or else (T1 = Universal_Integer and then Is_Integer_Type (T2))
or else (T1 = Universal_Real and then Is_Real_Type (T2))
or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2))
or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
then
return B2;
elsif False
or else (T2 = Universal_Integer and then Is_Integer_Type (T1))
or else (T2 = Universal_Real and then Is_Real_Type (T1))
or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
then
return B1;
elsif T2 = Any_String and then Is_String_Type (T1) then
return B1;
elsif T1 = Any_String and then Is_String_Type (T2) then
return B2;
elsif T2 = Any_Character and then Is_Character_Type (T1) then
return B1;
elsif T1 = Any_Character and then Is_Character_Type (T2) then
return B2;
elsif T1 = Any_Access
and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
then
return T2;
elsif T2 = Any_Access
and then (Is_Access_Type (T1) or else Is_Remote_Access (T1))
then
return T1;
elsif T2 = Any_Composite
and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
then
return T1;
elsif T1 = Any_Composite
and then Ekind (T2) in E_Array_Type .. E_Record_Subtype
then
return T2;
elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then
return T2;
elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
return T1;
elsif Is_Class_Wide_Type (T1)
and then Is_Class_Wide_Type (T2)
and then Is_Interface (Etype (T2))
then
return T1;
elsif Is_Class_Wide_Type (T2)
and then Is_Interface (Etype (T2))
and then Interface_Present_In_Ancestor (Typ => T1,
Iface => Etype (T2))
then
return T1;
elsif Is_Class_Wide_Type (T1)
and then Is_Ancestor (Root_Type (T1), T2)
then
return T1;
elsif Is_Class_Wide_Type (T2)
and then Is_Ancestor (Root_Type (T2), T1)
then
return T2;
elsif (Ekind (B1) = E_Access_Subprogram_Type
or else
Ekind (B1) = E_Access_Protected_Subprogram_Type)
and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
and then Is_Access_Type (T2)
then
return T2;
elsif (Ekind (B2) = E_Access_Subprogram_Type
or else
Ekind (B2) = E_Access_Protected_Subprogram_Type)
and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
and then Is_Access_Type (T1)
then
return T1;
elsif (Ekind (T1) = E_Allocator_Type
or else Ekind (T1) = E_Access_Attribute_Type
or else Ekind (T1) = E_Anonymous_Access_Type)
and then Is_Access_Type (T2)
then
return T2;
elsif (Ekind (T2) = E_Allocator_Type
or else Ekind (T2) = E_Access_Attribute_Type
or else Ekind (T2) = E_Anonymous_Access_Type)
and then Is_Access_Type (T1)
then
return T1;
else
return Any_Type;
end if;
end Specific_Type;
function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
begin
return Is_Boolean_Type (T)
or else T = Any_Composite
or else (Is_Array_Type (T)
and then T /= Any_String
and then Number_Dimensions (T) = 1
and then Is_Boolean_Type (Component_Type (T))
and then (not Is_Private_Composite (T)
or else In_Instance)
and then (not Is_Limited_Composite (T)
or else In_Instance))
or else Is_Modular_Integer_Type (T)
or else T = Universal_Integer;
end Valid_Boolean_Arg;
function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
begin
if T = Any_Composite then
return False;
elsif Is_Discrete_Type (T)
or else Is_Real_Type (T)
then
return True;
elsif Is_Array_Type (T)
and then Number_Dimensions (T) = 1
and then Is_Discrete_Type (Component_Type (T))
and then (not Is_Private_Composite (T)
or else In_Instance)
and then (not Is_Limited_Composite (T)
or else In_Instance)
then
return True;
elsif Is_String_Type (T) then
return True;
else
return False;
end if;
end Valid_Comparison_Arg;
procedure Write_Overloads (N : Node_Id) is
I : Interp_Index;
It : Interp;
Nam : Entity_Id;
begin
if not Is_Overloaded (N) then
Write_Str ("Non-overloaded entity ");
Write_Eol;
Write_Entity_Info (Entity (N), " ");
else
Get_First_Interp (N, I, It);
Write_Str ("Overloaded entity ");
Write_Eol;
Write_Str (" Name Type");
Write_Eol;
Write_Str ("===============================");
Write_Eol;
Nam := It.Nam;
while Present (Nam) loop
Write_Int (Int (Nam));
Write_Str (" ");
Write_Name (Chars (Nam));
Write_Str (" ");
Write_Int (Int (It.Typ));
Write_Str (" ");
Write_Name (Chars (It.Typ));
Write_Eol;
Get_Next_Interp (I, It);
Nam := It.Nam;
end loop;
end if;
end Write_Overloads;
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;