with Atree; use Atree;
with Debug; use Debug;
with Elists; use Elists;
with Einfo; use Einfo;
with Exp_Disp; use Exp_Disp;
with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
with Errout; use Errout;
with Hostparm; use Hostparm;
with Nlists; use Nlists;
with Opt; use Opt;
with Output; use Output;
with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Snames; use Snames;
with Sinfo; use Sinfo;
with Uintp; use Uintp;
package body Sem_Disp is
procedure Override_Dispatching_Operation
(Tagged_Type : Entity_Id;
Prev_Op : Entity_Id;
New_Op : Entity_Id);
procedure Add_Dispatching_Operation
(Tagged_Type : Entity_Id;
New_Op : Entity_Id);
function Check_Controlling_Type
(T : Entity_Id;
Subp : Entity_Id)
return Entity_Id;
procedure Add_Dispatching_Operation
(Tagged_Type : Entity_Id;
New_Op : Entity_Id)
is
List : constant Elist_Id := Primitive_Operations (Tagged_Type);
begin
Append_Elmt (New_Op, List);
end Add_Dispatching_Operation;
procedure Check_Controlling_Formals
(Typ : Entity_Id;
Subp : Entity_Id)
is
Formal : Entity_Id;
Ctrl_Type : Entity_Id;
Remote : constant Boolean :=
Is_Remote_Types (Current_Scope)
and then Comes_From_Source (Subp)
and then Scope (Typ) = Current_Scope;
begin
Formal := First_Formal (Subp);
while Present (Formal) loop
Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
if Present (Ctrl_Type) then
if Ctrl_Type = Typ then
Set_Is_Controlling_Formal (Formal);
if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
if not Subtypes_Statically_Match
(Typ, Designated_Type (Etype (Formal)))
then
Error_Msg_N
("parameter subtype does not match controlling type",
Formal);
end if;
elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then
Error_Msg_N
("parameter subtype does not match controlling type",
Formal);
end if;
if Present (Default_Value (Formal)) then
if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
Error_Msg_N
("default not allowed for controlling access parameter",
Default_Value (Formal));
elsif not Is_Tag_Indeterminate (Default_Value (Formal)) then
Error_Msg_N
("default expression must be a tag indeterminate" &
" function call", Default_Value (Formal));
end if;
end if;
elsif Comes_From_Source (Subp) then
Error_Msg_N
("operation can be dispatching in only one type", Subp);
end if;
elsif Remote
and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type
then
Error_Msg_N
("Access parameter of a remote subprogram must be controlling",
Formal);
end if;
Next_Formal (Formal);
end loop;
if Present (Etype (Subp)) then
Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
if Present (Ctrl_Type) then
if Ctrl_Type = Typ then
Set_Has_Controlling_Result (Subp);
if not Subtypes_Statically_Match (Typ, Etype (Subp)) then
Error_Msg_N
("result subtype does not match controlling type", Subp);
end if;
elsif Comes_From_Source (Subp) then
Error_Msg_N
("operation can be dispatching in only one type", Subp);
end if;
elsif Remote
and then Is_Limited_Type (Typ)
and then Etype (Subp) = Class_Wide_Type (Typ)
then
Error_Msg_N ("return type has no stream attributes", Subp);
end if;
end if;
end Check_Controlling_Formals;
function Check_Controlling_Type
(T : Entity_Id;
Subp : Entity_Id)
return Entity_Id
is
Tagged_Type : Entity_Id := Empty;
begin
if Is_Tagged_Type (T) then
if Is_First_Subtype (T) then
Tagged_Type := T;
else
Tagged_Type := Base_Type (T);
end if;
elsif Ekind (T) = E_Anonymous_Access_Type
and then Is_Tagged_Type (Designated_Type (T))
and then Ekind (Designated_Type (T)) /= E_Incomplete_Type
then
if Is_First_Subtype (Designated_Type (T)) then
Tagged_Type := Designated_Type (T);
else
Tagged_Type := Base_Type (Designated_Type (T));
end if;
end if;
if No (Tagged_Type)
or else Is_Class_Wide_Type (Tagged_Type)
then
return Empty;
elsif (Scope (Subp) = Scope (Tagged_Type)
or else Is_Internal (Subp))
and then
(not Is_Generic_Type (Tagged_Type)
or else not Comes_From_Source (Subp))
then
return Tagged_Type;
else
return Empty;
end if;
end Check_Controlling_Type;
procedure Check_Dispatching_Call (N : Node_Id) is
Actual : Node_Id;
Control : Node_Id := Empty;
Func : Entity_Id;
procedure Check_Dispatching_Context;
procedure Check_Dispatching_Context is
Func : constant Entity_Id := Entity (Name (N));
Par : Node_Id;
begin
if Is_Abstract (Func)
and then No (Controlling_Argument (N))
then
if Present (Alias (Func))
and then not Is_Abstract (Alias (Func))
and then No (DTC_Entity (Func))
then
Set_Entity (Name (N), Alias (Func));
return;
else
Par := Parent (N);
while Present (Par) loop
if (Nkind (Par) = N_Function_Call or else
Nkind (Par) = N_Procedure_Call_Statement or else
Nkind (Par) = N_Assignment_Statement or else
Nkind (Par) = N_Op_Eq or else
Nkind (Par) = N_Op_Ne)
and then Is_Tagged_Type (Etype (Func))
then
return;
elsif Nkind (Par) = N_Qualified_Expression
or else Nkind (Par) = N_Unchecked_Type_Conversion
then
Par := Parent (Par);
else
Error_Msg_N
("call to abstract function must be dispatching", N);
return;
end if;
end loop;
end if;
end if;
end Check_Dispatching_Context;
begin
if Present (Parameter_Associations (N)) then
Actual := First_Actual (N);
while Present (Actual) loop
Control := Find_Controlling_Arg (Actual);
exit when Present (Control);
Next_Actual (Actual);
end loop;
if Present (Control) then
if Debug_Flag_E then
Write_Str ("Found Dispatching call");
Write_Int (Int (N));
Write_Eol;
end if;
Actual := First_Actual (N);
while Present (Actual) loop
if Actual /= Control then
if not Is_Controlling_Actual (Actual) then
null;
elsif (Is_Dynamically_Tagged (Actual)) then
null;
elsif Is_Tag_Indeterminate (Actual) then
Propagate_Tag (Control, Actual);
else
Error_Msg_N
("controlling argument is not dynamically tagged",
Actual);
return;
end if;
end if;
Next_Actual (Actual);
end loop;
Set_Controlling_Argument (N, Control);
else
Actual := First_Actual (N);
while Present (Actual) loop
if Is_Tag_Indeterminate (Actual) then
if Nkind (Original_Node (Actual)) = N_Function_Call then
Func := Entity (Name (Original_Node (Actual)));
else
Func :=
Entity (Name
(Original_Node
(Expression (Original_Node (Actual)))));
end if;
if Is_Abstract (Func) then
Error_Msg_N (
"call to abstract function must be dispatching", N);
end if;
end if;
Next_Actual (Actual);
end loop;
Check_Dispatching_Context;
end if;
else
Check_Dispatching_Context;
end if;
end Check_Dispatching_Call;
procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
Tagged_Type : Entity_Id;
Has_Dispatching_Parent : Boolean := False;
Body_Is_Last_Primitive : Boolean := False;
begin
if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then
return;
end if;
Set_Is_Dispatching_Operation (Subp, False);
Tagged_Type := Find_Dispatching_Type (Subp);
Has_Dispatching_Parent := Present (Alias (Subp))
and then Is_Dispatching_Operation (Alias (Subp));
if No (Tagged_Type) then
return;
elsif Is_Frozen (Tagged_Type)
and then not Comes_From_Source (Subp)
and then not Has_Dispatching_Parent
then
return;
elsif Is_Child_Unit (Subp) then
return;
elsif ((not Is_Package (Scope (Subp)))
or else In_Package_Body (Scope (Subp)))
and then not Has_Dispatching_Parent
then
if not Comes_From_Source (Subp)
or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Type))
then
null;
elsif Present (Old_Subp)
and then Is_Dispatching_Operation (Old_Subp)
then
if Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
and then Comes_From_Source (Subp)
then
declare
Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
Decl_Item : Node_Id := Next (Parent (Tagged_Type));
begin
while Present (Decl_Item)
and then (Decl_Item /= Subp_Body)
loop
if Comes_From_Source (Decl_Item)
and then (Nkind (Decl_Item) in N_Proper_Body
or else Nkind (Decl_Item) in N_Body_Stub)
then
Error_Msg_N ("overriding of& is too late!", Subp);
Error_Msg_N
("\spec should appear immediately after the type!",
Subp);
exit;
end if;
Next (Decl_Item);
end loop;
if not Present (Decl_Item) then
Error_Msg_N ("overriding of& is too late!", Subp);
Error_Msg_N
("\spec should appear immediately after the type!",
Subp);
elsif Is_Frozen (Subp) then
Body_Is_Last_Primitive := True;
if Present (DTC_Entity (Old_Subp)) then
Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
Set_DT_Position (Subp, DT_Position (Old_Subp));
Insert_After (
Subp_Body, Fill_DT_Entry (Sloc (Subp_Body), Subp));
end if;
end if;
end;
else
Error_Msg_N ("overriding of& is too late!", Subp);
Error_Msg_N
("\subprogram spec should appear immediately after the type!",
Subp);
end if;
elsif not Is_Frozen (Tagged_Type) then
Error_Msg_N
("?not dispatching (must be defined in a package spec)", Subp);
return;
else
return;
end if;
elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then
Error_Msg_N ("this primitive operation is declared too late", Subp);
Error_Msg_NE
("?no primitive operations for& after this line",
Freeze_Node (Tagged_Type),
Tagged_Type);
return;
end if;
Check_Controlling_Formals (Tagged_Type, Subp);
if Present (Old_Subp) then
Check_Subtype_Conformant (Subp, Old_Subp);
Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
else
Add_Dispatching_Operation (Tagged_Type, Subp);
end if;
Set_Is_Dispatching_Operation (Subp, True);
if not Body_Is_Last_Primitive then
Set_DT_Position (Subp, No_Uint);
elsif Has_Controlled_Component (Tagged_Type)
and then
(Chars (Subp) = Name_Initialize
or else Chars (Subp) = Name_Adjust
or else Chars (Subp) = Name_Finalize)
then
declare
F_Node : Node_Id := Freeze_Node (Tagged_Type);
Decl : Node_Id;
Old_P : Entity_Id;
Old_Bod : Node_Id;
Old_Spec : Entity_Id;
C_Names : constant array (1 .. 3) of Name_Id :=
(Name_Initialize,
Name_Adjust,
Name_Finalize);
D_Names : constant array (1 .. 3) of Name_Id :=
(Name_uDeep_Initialize,
Name_uDeep_Adjust,
Name_uDeep_Finalize);
begin
for J in D_Names'Range loop
Old_P := TSS (Tagged_Type, D_Names (J));
if Present (Old_P)
and then Chars (Subp) = C_Names (J)
then
Old_Bod := Unit_Declaration_Node (Old_P);
Remove (Old_Bod);
Set_Is_Eliminated (Old_P);
Set_Scope (Old_P, Scope (Current_Scope));
if Nkind (Old_Bod) = N_Subprogram_Body
and then Present (Corresponding_Spec (Old_Bod))
then
Old_Spec := Corresponding_Spec (Old_Bod);
Set_Has_Completion (Old_Spec, False);
if Exception_Mechanism = Front_End_ZCX then
Set_Has_Subprogram_Descriptor (Old_Spec, False);
Set_Handler_Records (Old_Spec, No_List);
Set_Is_Eliminated (Old_Spec);
end if;
end if;
end if;
end loop;
Build_Late_Proc (Tagged_Type, Chars (Subp));
if Present (F_Node)
and then Present (Actions (F_Node))
then
Decl := Last (Actions (F_Node));
Analyze (Decl);
end if;
end;
end if;
end Check_Dispatching_Operation;
procedure Check_Operation_From_Incomplete_Type
(Subp : Entity_Id;
Typ : Entity_Id)
is
Full : constant Entity_Id := Full_View (Typ);
Parent_Typ : constant Entity_Id := Etype (Full);
Old_Prim : constant Elist_Id := Primitive_Operations (Parent_Typ);
New_Prim : constant Elist_Id := Primitive_Operations (Full);
Op1, Op2 : Elmt_Id;
Prev : Elmt_Id := No_Elmt;
function Derives_From (Proc : Entity_Id) return Boolean;
function Derives_From (Proc : Entity_Id) return Boolean is
F1, F2 : Entity_Id;
begin
if Chars (Proc) /= Chars (Subp) then
return False;
end if;
F1 := First_Formal (Proc);
F2 := First_Formal (Subp);
while Present (F1) and then Present (F2) loop
if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
return False;
elsif Designated_Type (Etype (F1)) = Parent_Typ
and then Designated_Type (Etype (F2)) /= Full
then
return False;
end if;
elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then
return False;
elsif Etype (F1) /= Etype (F2) then
return False;
end if;
Next_Formal (F1);
Next_Formal (F2);
end loop;
return No (F1) and then No (F2);
end Derives_From;
begin
Op1 := First_Elmt (Old_Prim);
Op2 := First_Elmt (New_Prim);
while Present (Op1) and then Present (Op2) loop
if Derives_From (Node (Op1)) then
if No (Prev) then
Prepend_Elmt (Subp, New_Prim);
else
Insert_Elmt_After (Subp, Prev);
end if;
return;
end if;
Prev := Op2;
Next_Elmt (Op1);
Next_Elmt (Op2);
end loop;
Append_Elmt (Subp, New_Prim);
end Check_Operation_From_Incomplete_Type;
procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is
Tagged_Type : Entity_Id;
begin
if Is_Dispatching_Operation (Alias (Subp)) then
Set_Scope (Subp, Current_Scope);
Tagged_Type := Find_Dispatching_Type (Subp);
if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
Append_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
if not Is_Dispatching_Operation (Old_Subp) then
Check_Controlling_Formals (Tagged_Type, Old_Subp);
Set_Is_Dispatching_Operation (Old_Subp, True);
Set_DT_Position (Old_Subp, No_Uint);
end if;
if Present (Alias (Old_Subp))
and then Nkind (Unit_Declaration_Node (Old_Subp))
/= N_Subprogram_Renaming_Declaration
then
Set_Alias (Old_Subp, Alias (Subp));
if Etype (Subp) /= Tagged_Type then
Set_Is_Abstract (Old_Subp, Is_Abstract (Alias (Subp)));
end if;
end if;
end if;
end if;
end Check_Operation_From_Private_View;
function Find_Controlling_Arg (N : Node_Id) return Node_Id is
Orig_Node : constant Node_Id := Original_Node (N);
Typ : Entity_Id;
begin
if Nkind (Orig_Node) = N_Qualified_Expression then
return Find_Controlling_Arg (Expression (Orig_Node));
end if;
if Nkind (Orig_Node) = N_Function_Call
and then Present (Controlling_Argument (Orig_Node))
and then Has_Controlling_Result (Entity (Name (Orig_Node)))
then
return Controlling_Argument (Orig_Node);
elsif Is_Controlling_Actual (N) then
Typ := Etype (N);
if Is_Access_Type (Typ) then
if Nkind (N) = N_Attribute_Reference then
Typ := Etype (Prefix (N));
elsif Nkind (Orig_Node) = N_Allocator
and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
then
Typ := Etype (Expression (Orig_Node));
else
Typ := Designated_Type (Typ);
end if;
end if;
if Is_Class_Wide_Type (Typ) then
return N;
end if;
end if;
return Empty;
end Find_Controlling_Arg;
function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
Formal : Entity_Id;
Ctrl_Type : Entity_Id;
begin
if Present (DTC_Entity (Subp)) then
return Scope (DTC_Entity (Subp));
else
Formal := First_Formal (Subp);
while Present (Formal) loop
Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
if Present (Ctrl_Type) then
return Ctrl_Type;
end if;
Next_Formal (Formal);
end loop;
if Present (Etype (Subp)) then
Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
if Present (Ctrl_Type) then
return Ctrl_Type;
end if;
end if;
end if;
return Empty;
end Find_Dispatching_Type;
function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
begin
return Find_Controlling_Arg (N) /= Empty;
end Is_Dynamically_Tagged;
function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
Nam : Entity_Id;
Actual : Node_Id;
Orig_Node : constant Node_Id := Original_Node (N);
begin
if Nkind (Orig_Node) = N_Function_Call
and then Is_Entity_Name (Name (Orig_Node))
then
Nam := Entity (Name (Orig_Node));
if not Has_Controlling_Result (Nam) then
return False;
elsif No (Parameter_Associations (Orig_Node)) then
return True;
else
Actual := First_Actual (Orig_Node);
while Present (Actual) loop
if Is_Controlling_Actual (Actual)
and then not Is_Tag_Indeterminate (Actual)
then
return False; end if;
Next_Actual (Actual);
end loop;
return True;
end if;
elsif Nkind (Orig_Node) = N_Qualified_Expression then
return Is_Tag_Indeterminate (Expression (Orig_Node));
else
return False;
end if;
end Is_Tag_Indeterminate;
procedure Override_Dispatching_Operation
(Tagged_Type : Entity_Id;
Prev_Op : Entity_Id;
New_Op : Entity_Id)
is
Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
begin
while Present (Op_Elmt)
and then Node (Op_Elmt) /= Prev_Op
loop
Next_Elmt (Op_Elmt);
end loop;
if No (Op_Elmt) then
return;
end if;
Replace_Elmt (Op_Elmt, New_Op);
if (not Is_Package (Current_Scope))
or else not In_Private_Part (Current_Scope)
then
null;
else pragma Assert (Is_Inherited_Operation (Prev_Op));
Set_Alias (Prev_Op, New_Op);
Set_DTC_Entity (Prev_Op, Empty);
return;
end if;
end Override_Dispatching_Operation;
procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
Call_Node : Node_Id;
Arg : Node_Id;
begin
if Nkind (Actual) = N_Function_Call then
Call_Node := Actual;
elsif Nkind (Actual) = N_Identifier
and then Nkind (Original_Node (Actual)) = N_Function_Call
then
Call_Node := Expression (Parent (Entity (Actual)));
else
Call_Node := Expression (Actual);
end if;
if No (Controlling_Argument (Call_Node)) then
Set_Controlling_Argument (Call_Node, Control);
end if;
Arg := First_Actual (Call_Node);
while Present (Arg) loop
if Is_Tag_Indeterminate (Arg) then
Propagate_Tag (Control, Arg);
end if;
Next_Actual (Arg);
end loop;
if not Java_VM then
Expand_Dispatch_Call (Call_Node);
end if;
end Propagate_Tag;
end Sem_Disp;