with Elists; use Elists;
with Einfo; use Einfo;
with Exp_Disp; use Exp_Disp;
+with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
with Errout; use Errout;
with Hostparm; use Hostparm;
with Nlists; use Nlists;
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);
if Ctrl_Type = Typ then
Set_Is_Controlling_Formal (Formal);
- -- Ada 2005 (AI-231):Anonymous access types used in controlling
- -- parameters exclude null because it is necessary to read the
- -- tag to dispatch, and null has no tag.
+ -- Ada 2005 (AI-231): Anonymous access types used in
+ -- controlling parameters exclude null because it is necessary
+ -- to read the tag to dispatch, and null has no tag.
if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
Set_Can_Never_Be_Null (Etype (Formal));
Error_Msg_N
("operation can be dispatching in only one type", Subp);
end if;
-
- -- Verify that the restriction in E.2.2 (14) is obeyed
-
- elsif Remote
- and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type
- then
- Error_Msg_N
- ("access parameter of remote object primitive"
- & " must be controlling",
- Formal);
end if;
Next_Formal (Formal);
if Ctrl_Type = Typ then
Set_Has_Controlling_Result (Subp);
- -- Check that the result subtype statically matches
- -- the first subtype.
+ -- Check that result subtype statically matches first subtype
if not Subtypes_Statically_Match (Typ, Etype (Subp)) then
Error_Msg_N
Error_Msg_N
("operation can be dispatching in only one type", Subp);
end if;
-
- -- The following check is clearly required, although the RM says
- -- nothing about return types. If the return type is a limited
- -- class-wide type declared in the current scope, there is no way
- -- to declare stream procedures for it, so the return cannot be
- -- marshalled.
-
- 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;
Set_Controlling_Argument (N, Control);
+ -- Ada 2005 (AI-318-02): Check current implementation restriction
+ -- that a dispatching call cannot be made to a primitive function
+ -- with a limited result type. This restriction can be removed
+ -- once calls to limited functions with class-wide results are
+ -- supported. ???
+
+ if Ada_Version = Ada_05
+ and then Nkind (N) = N_Function_Call
+ then
+ Func := Entity (Name (N));
+
+ if Has_Controlling_Result (Func)
+ and then Is_Limited_Type (Etype (Func))
+ then
+ Error_Msg_N ("(Ada 2005) limited function call in this" &
+ " context is not yet implemented", N);
+ end if;
+ end if;
+
else
-- The call is not dispatching, so check that there aren't any
-- tag-indeterminate abstract calls left.
and then Is_Dispatching_Operation (Alias (Subp));
if No (Tagged_Type) then
+
+ -- Ada 2005 (AI-251): Check that Subp is not a primitive associated
+ -- with an abstract interface type unless the interface acts as a
+ -- parent type in a derivation. If the interface type is a formal
+ -- type then the operation is not primitive and therefore legal.
+
+ declare
+ E : Entity_Id;
+ Typ : Entity_Id;
+
+ begin
+ E := First_Entity (Subp);
+ while Present (E) loop
+ if Is_Access_Type (Etype (E)) then
+ Typ := Designated_Type (Etype (E));
+ else
+ Typ := Etype (E);
+ end if;
+
+ if not Is_Class_Wide_Type (Typ)
+ and then Is_Interface (Typ)
+ and then not Is_Derived_Type (Typ)
+ and then not Is_Generic_Type (Typ)
+ then
+ Error_Msg_N ("?declaration of& is too late!", Subp);
+ Error_Msg_NE
+ ("\spec should appear immediately after declaration of &!",
+ Subp, Typ);
+ exit;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ -- In case of functions check also the result type
+
+ if Ekind (Subp) = E_Function then
+ if Is_Access_Type (Etype (Subp)) then
+ Typ := Designated_Type (Etype (Subp));
+ else
+ Typ := Etype (Subp);
+ end if;
+
+ if not Is_Class_Wide_Type (Typ)
+ and then Is_Interface (Typ)
+ and then not Is_Derived_Type (Typ)
+ then
+ Error_Msg_N ("?declaration of& is too late!", Subp);
+ Error_Msg_NE
+ ("\spec should appear immediately after declaration of &!",
+ Subp, Typ);
+ end if;
+ end if;
+ end;
+
return;
-- The subprograms build internally after the freezing point (such as
else
Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
Set_Is_Overriding_Operation (Subp);
+
+ -- Ada 2005 (AI-251): In case of late overriding of a primitive
+ -- that covers abstract interface subprograms we must register it
+ -- in all the secondary dispatch tables associated with abstract
+ -- interfaces.
+
+ if Body_Is_Last_Primitive then
+ declare
+ Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
+ Elmt : Elmt_Id;
+ Prim : Node_Id;
+
+ begin
+ Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
+ while Present (Elmt) loop
+ Prim := Node (Elmt);
+
+ if Present (Alias (Prim))
+ and then Present (Abstract_Interface_Alias (Prim))
+ and then Alias (Prim) = Subp
+ then
+ Register_Interface_DT_Entry (Subp_Body, Prim);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- Redisplay the contents of the updated dispatch table.
+
+ if Debug_Flag_ZZ then
+ Write_Str ("Late overriding: ");
+ Write_DT (Tagged_Type);
+ end if;
+ end;
+ end if;
end if;
-- If no old subprogram, then we add this as a dispatching operation,
-- The new operation is added to the actions of the freeze
-- node for the type, but this node has already been analyzed,
- -- so we must retrieve and analyze explicitly the one new body,
+ -- so we must retrieve and analyze explicitly the new body.
if Present (F_Node)
and then Present (Actions (F_Node))
Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference
then
return True;
+
+ -- In Ada 2005 a function that returns an anonymous access type can
+ -- dispatching, and the dereference of a call to such a function
+ -- is also tag-indeterminate.
+
+ elsif Nkind (Orig_Node) = N_Explicit_Dereference
+ and then Ada_Version >= Ada_05
+ then
+ return Is_Tag_Indeterminate (Prefix (Orig_Node));
+
else
return False;
end if;
Prev_Op : Entity_Id;
New_Op : Entity_Id)
is
- Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
- Elmt : Elmt_Id;
- Found : Boolean;
- E : Entity_Id;
-
- function Is_Interface_Subprogram (Op : Entity_Id) return Boolean;
- -- Traverse the list of aliased entities to check if the overriden
- -- entity corresponds with a primitive operation of an abstract
- -- interface type.
-
- -----------------------------
- -- Is_Interface_Subprogram --
- -----------------------------
-
- function Is_Interface_Subprogram (Op : Entity_Id) return Boolean is
- Aux : Entity_Id;
-
- begin
- Aux := Op;
- while Present (Alias (Aux))
- and then Present (DTC_Entity (Alias (Aux)))
- loop
- if Is_Interface (Scope (DTC_Entity (Alias (Aux)))) then
- return True;
- end if;
- Aux := Alias (Aux);
- end loop;
-
- return False;
- end Is_Interface_Subprogram;
-
- -- Start of processing for Override_Dispatching_Operation
+ Elmt : Elmt_Id;
+ Prim : Node_Id;
begin
-- Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
Error_Msg_N ("\since overridden procedure has No_Return", New_Op);
end if;
- -- Patch the primitive operation list
+ -- If there is no previous operation to override, the type declaration
+ -- was malformed, and an error must have been emitted already.
- while Present (Op_Elmt)
- and then Node (Op_Elmt) /= Prev_Op
+ Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
+ while Present (Elmt)
+ and then Node (Elmt) /= Prev_Op
loop
- Next_Elmt (Op_Elmt);
+ Next_Elmt (Elmt);
end loop;
- -- If there is no previous operation to override, the type declaration
- -- was malformed, and an error must have been emitted already.
-
- if No (Op_Elmt) then
+ if No (Elmt) then
return;
end if;
- -- Ada 2005 (AI-251): Do not replace subprograms inherited from
- -- abstract interfaces. They will be used later to generate the
- -- corresponding thunks to initialize the Vtable (see subprogram
- -- Freeze_Subprogram). The inherited operation itself must also
- -- become hidden, to avoid spurious ambiguities; name resolution
- -- must pick up only the operation that implements it,
-
- if Is_Interface_Subprogram (Prev_Op) then
- Set_DT_Position (Prev_Op, DT_Position (Alias (Prev_Op)));
- Set_Is_Abstract (Prev_Op, Is_Abstract (New_Op));
- Set_Is_Overriding_Operation (Prev_Op);
-
- -- Traverse the list of aliased entities to look for the overriden
- -- abstract interface subprogram.
-
- E := Alias (Prev_Op);
- while Present (Alias (E))
- and then Present (DTC_Entity (E))
- and then not (Is_Abstract (E))
- and then not Is_Interface (Scope (DTC_Entity (E)))
- loop
- E := Alias (E);
- end loop;
+ Replace_Elmt (Elmt, New_Op);
- Set_Abstract_Interface_Alias (Prev_Op, E);
- Set_Alias (Prev_Op, New_Op);
- Set_Is_Internal (Prev_Op);
- Set_Is_Hidden (Prev_Op);
+ if Ada_Version >= Ada_05
+ and then Has_Abstract_Interfaces (Tagged_Type)
+ then
+ -- Ada 2005 (AI-251): Update the attribute alias of all the aliased
+ -- entities of the overriden primitive to reference New_Op, and also
+ -- propagate them the new value of the attribute Is_Abstract.
- -- Override predefined primitive operations
+ Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
+ while Present (Elmt) loop
+ Prim := Node (Elmt);
- if Is_Predefined_Dispatching_Operation (Prev_Op) then
- Replace_Elmt (Op_Elmt, New_Op);
- return;
- end if;
+ if Prim = New_Op then
+ null;
- -- Check if this primitive operation was previously added for another
- -- interface.
+ elsif Present (Abstract_Interface_Alias (Prim))
+ and then Alias (Prim) = Prev_Op
+ then
+ Set_Alias (Prim, New_Op);
+ Set_Is_Abstract (Prim, Is_Abstract (New_Op));
- Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
- Found := False;
- while Present (Elmt) loop
- if Node (Elmt) = New_Op then
- Found := True;
- exit;
+ -- Ensure that this entity will be expanded to fill the
+ -- corresponding entry in its dispatch table.
+
+ if not Is_Abstract (Prim) then
+ Set_Has_Delayed_Freeze (Prim);
+ end if;
end if;
Next_Elmt (Elmt);
end loop;
-
- if not Found then
- Append_Elmt (New_Op, Primitive_Operations (Tagged_Type));
- end if;
-
- return;
-
- else
- Replace_Elmt (Op_Elmt, New_Op);
end if;
if (not Is_Package_Or_Generic_Package (Current_Scope))
Call_Node := Expression (Parent (Entity (Actual)));
+ -- Ada 2005: If this is a dereference of a call to a function with a
+ -- dispatching access-result, the tag is propagated when the dereference
+ -- itself is expanded (see exp_ch6.adb) and there is nothing else to do.
+
+ elsif Nkind (Actual) = N_Explicit_Dereference
+ and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call
+ then
+ return;
+
-- Only other possibilities are parenthesized or qualified expression,
-- or an expander-generated unchecked conversion of a function call to
-- a stream Input attribute.
OSDN Git Service
