-- --
-- B o d y --
-- --
--- $Revision: 1.114 $
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
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 Exp_Util; use Exp_Util;
with Errout; use Errout;
with Hostparm; use Hostparm;
with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
with Output; use Output;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6;
with Sem_Eval; use Sem_Eval;
+with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
+with Snames; use Snames;
+with Stand; use Stand;
with Sinfo; use Sinfo;
+with Tbuild; use Tbuild;
with Uintp; use Uintp;
package body Sem_Disp is
-- Local Subprograms --
-----------------------
- procedure Override_Dispatching_Operation
- (Tagged_Type : Entity_Id;
- Prev_Op : Entity_Id;
- New_Op : Entity_Id);
- -- Replace an implicit dispatching operation with an explicit one.
- -- Prev_Op is an inherited primitive operation which is overridden
- -- by the explicit declaration of New_Op.
-
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;
- -- T is the type of a formal parameter of subp. Returns the tagged
- -- if the parameter can be a controlling argument, empty otherwise
+ Subp : Entity_Id) return Entity_Id;
+ -- T is the tagged type of a formal parameter or the result of Subp.
+ -- If the subprogram has a controlling parameter or result that matches
+ -- the type, then returns the tagged type of that parameter or result
+ -- (returning the designated tagged type in the case of an access
+ -- parameter); otherwise returns empty.
- --------------------------------
- -- Add_Dispatching_Operation --
- --------------------------------
+ -------------------------------
+ -- Add_Dispatching_Operation --
+ -------------------------------
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;
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.
+
+ if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
+ Set_Can_Never_Be_Null (Etype (Formal));
+ Set_Is_Known_Non_Null (Etype (Formal));
+ end if;
+
-- Check that the parameter's nominal subtype statically
-- matches the first subtype.
("operation can be dispatching in only one type", Subp);
end if;
- -- Verify that the restriction in E.2.2 (1) is obeyed.
+ -- 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 a remote subprogram must be controlling",
+ ("access parameter of remote object primitive"
+ & " must be controlling",
Formal);
end if;
function Check_Controlling_Type
(T : Entity_Id;
- Subp : Entity_Id)
- return Entity_Id
+ Subp : Entity_Id) return Entity_Id
is
Tagged_Type : Entity_Id := Empty;
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));
+ if 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;
+
+ -- Ada 2005 (AI-50217)
+
+ elsif From_With_Type (Designated_Type (T))
+ and then Present (Non_Limited_View (Designated_Type (T)))
+ then
+ if Is_First_Subtype (Non_Limited_View (Designated_Type (T))) then
+ Tagged_Type := Non_Limited_View (Designated_Type (T));
+ else
+ Tagged_Type := Base_Type (Non_Limited_View
+ (Designated_Type (T)));
+ end if;
end if;
end if;
return Empty;
-- The dispatching type and the primitive operation must be defined
- -- in the same scope except for internal operations.
-
- 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))
+ -- in the same scope, except in the case of internal operations and
+ -- formal abstract subprograms.
+
+ 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)))
+ or else
+ (Is_Formal_Subprogram (Subp) and then Is_Abstract (Subp))
+ or else
+ (Nkind (Parent (Parent (Subp))) = N_Subprogram_Renaming_Declaration
+ and then
+ Present (Corresponding_Formal_Spec (Parent (Parent (Subp))))
+ and then
+ Is_Abstract (Subp))
then
return Tagged_Type;
----------------------------
procedure Check_Dispatching_Call (N : Node_Id) is
- Actual : Node_Id;
- Control : Node_Id := Empty;
- Func : Entity_Id;
+ Actual : Node_Id;
+ Formal : Entity_Id;
+ Control : Node_Id := Empty;
+ Func : Entity_Id;
+ Subp_Entity : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Indeterm_Ancestor_Call : Boolean := False;
+ Indeterm_Ctrl_Type : Entity_Id;
procedure Check_Dispatching_Context;
-- If the call is tag-indeterminate and the entity being called is
-------------------------------
procedure Check_Dispatching_Context is
- Func : constant Entity_Id := Entity (Name (N));
+ Subp : constant Entity_Id := Entity (Name (N));
Par : Node_Id;
begin
- if Is_Abstract (Func)
+ if Is_Abstract (Subp)
and then No (Controlling_Argument (N))
then
- Par := Parent (N);
+ if Present (Alias (Subp))
+ and then not Is_Abstract (Alias (Subp))
+ and then No (DTC_Entity (Subp))
+ then
+ -- Private overriding of inherited abstract operation,
+ -- call is legal.
- while Present (Par) loop
+ Set_Entity (Name (N), Alias (Subp));
+ return;
- 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
- then
- return;
+ else
+ Par := Parent (N);
- elsif Nkind (Par) = N_Qualified_Expression
- or else Nkind (Par) = N_Unchecked_Type_Conversion
- then
- Par := Parent (Par);
+ while Present (Par) loop
- else
- Error_Msg_N
- ("call to abstract function must be dispatching", N);
- return;
- end if;
- end 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 (Subp))
+ then
+ return;
+
+ elsif Nkind (Par) = N_Qualified_Expression
+ or else Nkind (Par) = N_Unchecked_Type_Conversion
+ then
+ Par := Parent (Par);
+
+ else
+ if Ekind (Subp) = E_Function then
+ Error_Msg_N
+ ("call to abstract function must be dispatching", N);
+
+ -- This error can occur for a procedure in the case of a
+ -- call to an abstract formal procedure with a statically
+ -- tagged operand.
+
+ else
+ Error_Msg_N
+ ("call to abstract procedure must be dispatching",
+ N);
+ end if;
+
+ return;
+ end if;
+ end loop;
+ end if;
end if;
end Check_Dispatching_Context;
if Present (Parameter_Associations (N)) then
Actual := First_Actual (N);
+ Subp_Entity := Entity (Name (N));
+ Formal := First_Formal (Subp_Entity);
+
while Present (Actual) loop
Control := Find_Controlling_Arg (Actual);
exit when Present (Control);
+
+ -- Check for the case where the actual is a tag-indeterminate call
+ -- whose result type is different than the tagged type associated
+ -- with the containing call, but is an ancestor of the type.
+
+ if Is_Controlling_Formal (Formal)
+ and then Is_Tag_Indeterminate (Actual)
+ and then Base_Type (Etype (Actual)) /= Base_Type (Etype (Formal))
+ and then Is_Ancestor (Etype (Actual), Etype (Formal))
+ then
+ Indeterm_Ancestor_Call := True;
+ Indeterm_Ctrl_Type := Etype (Formal);
+ end if;
+
Next_Actual (Actual);
+ Next_Formal (Formal);
end loop;
+ -- If the call doesn't have a controlling actual but does have
+ -- an indeterminate actual that requires dispatching treatment,
+ -- then an object is needed that will serve as the controlling
+ -- argument for a dispatching call on the indeterminate actual.
+ -- This can only occur in the unusual situation of a default
+ -- actual given by a tag-indeterminate call and where the type
+ -- of the call is an ancestor of the type associated with a
+ -- containing call to an inherited operation (see AI-239).
+ -- Rather than create an object of the tagged type, which would
+ -- be problematic for various reasons (default initialization,
+ -- discriminants), the tag of the containing call's associated
+ -- tagged type is directly used to control the dispatching.
+
+ if No (Control)
+ and then Indeterm_Ancestor_Call
+ then
+ Control :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Indeterm_Ctrl_Type, Loc),
+ Attribute_Name => Name_Tag);
+ Analyze (Control);
+ end if;
+
if Present (Control) then
-- Verify that no controlling arguments are statically tagged
if Actual /= Control then
if not Is_Controlling_Actual (Actual) then
- null; -- can be anything
+ null; -- Can be anything
- elsif (Is_Dynamically_Tagged (Actual)) then
- null; -- valid parameter
+ elsif Is_Dynamically_Tagged (Actual) then
+ null; -- Valid parameter
elsif Is_Tag_Indeterminate (Actual) then
Set_Controlling_Argument (N, Control);
else
- -- The call is not dispatching, check that there isn't any
- -- tag indeterminate abstract call left
+ -- The call is not dispatching, so check that there aren't any
+ -- tag-indeterminate abstract calls left.
Actual := First_Actual (N);
if Nkind (Original_Node (Actual)) = N_Function_Call then
Func := Entity (Name (Original_Node (Actual)));
+ -- If the actual is an attribute then it can't be abstract
+ -- (the only current case of a tag-indeterminate attribute
+ -- is the stream Input attribute).
+
+ elsif
+ Nkind (Original_Node (Actual)) = N_Attribute_Reference
+ then
+ Func := Empty;
+
-- Only other possibility is a qualified expression whose
-- consituent expression is itself a call.
(Expression (Original_Node (Actual)))));
end if;
- if Is_Abstract (Func) then
+ if Present (Func) and then Is_Abstract (Func) then
Error_Msg_N (
"call to abstract function must be dispatching", N);
end if;
---------------------------------
procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
- Tagged_Seen : Entity_Id;
+ Tagged_Type : Entity_Id;
Has_Dispatching_Parent : Boolean := False;
Body_Is_Last_Primitive : Boolean := False;
+ function Is_Visibly_Controlled (T : Entity_Id) return Boolean;
+ -- Check whether T is derived from a visibly controlled type.
+ -- This is true if the root type is declared in Ada.Finalization.
+ -- If T is derived instead from a private type whose full view
+ -- is controlled, an explicit Initialize/Adjust/Finalize subprogram
+ -- does not override the inherited one.
+
+ ---------------------------
+ -- Is_Visibly_Controlled --
+ ---------------------------
+
+ function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
+ Root : constant Entity_Id := Root_Type (T);
+ begin
+ return Chars (Scope (Root)) = Name_Finalization
+ and then Chars (Scope (Scope (Root))) = Name_Ada
+ and then Scope (Scope (Scope (Root))) = Standard_Standard;
+ end Is_Visibly_Controlled;
+
+ -- Start of processing for Check_Dispatching_Operation
+
begin
if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then
return;
end if;
Set_Is_Dispatching_Operation (Subp, False);
- Tagged_Seen := Find_Dispatching_Type (Subp);
+ Tagged_Type := Find_Dispatching_Type (Subp);
+
+ -- Ada 2005 (AI-345)
+
+ if Ada_Version = Ada_05
+ and then Present (Tagged_Type)
+ and then Is_Concurrent_Type (Tagged_Type)
+ then
+ -- Protect the frontend against previously detected errors
+
+ if No (Corresponding_Record_Type (Tagged_Type)) then
+ return;
+ end if;
+
+ Tagged_Type := Corresponding_Record_Type (Tagged_Type);
+ end if;
-- If Subp is derived from a dispatching operation then it should
-- always be treated as dispatching. In this case various checks
-- inherited private subprograms are treated as dispatching, even
-- if the associated tagged type is already frozen.
- Has_Dispatching_Parent := Present (Alias (Subp))
- and then Is_Dispatching_Operation (Alias (Subp));
+ Has_Dispatching_Parent :=
+ Present (Alias (Subp))
+ and then Is_Dispatching_Operation (Alias (Subp));
- if No (Tagged_Seen) then
+ if No (Tagged_Type) then
return;
-- The subprograms build internally after the freezing point (such as
-- the Init procedure) are not primitives
- elsif Is_Frozen (Tagged_Seen)
+ elsif Is_Frozen (Tagged_Type)
and then not Comes_From_Source (Subp)
and then not Has_Dispatching_Parent
then
-- where it can be a dispatching op is when it overrides an operation
-- before the freezing point of the type.
- elsif ((not Is_Package (Scope (Subp)))
- or else In_Package_Body (Scope (Subp)))
+ elsif ((not Is_Package_Or_Generic_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_Seen))
+ 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)
+ if Comes_From_Source (Subp)
+ and then
+ (Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
+ or else Nkind (Unit_Declaration_Node (Subp)) in N_Body_Stub)
then
declare
Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
- Decl_Item : Node_Id := Next (Parent (Tagged_Seen));
+ Decl_Item : Node_Id := Next (Parent (Tagged_Type));
begin
-- ??? The checks here for whether the type has been
-- has definitely been frozen already and the body
-- is illegal.
- if not Present (Decl_Item) then
+ if No (Decl_Item) then
Error_Msg_N ("overriding of& is too late!", Subp);
Error_Msg_N
("\spec should appear immediately after the type!",
elsif Is_Frozen (Subp) then
- -- the subprogram body declares a primitive operation.
+ -- The subprogram body declares a primitive operation.
-- if the subprogram is already frozen, we must update
-- its dispatching information explicitly here. The
-- information is taken from the overridden subprogram.
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));
+
+ if not Restriction_Active (No_Dispatching_Calls) then
+ Insert_After (Subp_Body,
+ Fill_DT_Entry (Sloc (Subp_Body), Subp));
+ end if;
end if;
end if;
end;
-- case it looks suspiciously like an attempt to define a primitive
-- operation.
- elsif not Is_Frozen (Tagged_Seen) then
+ elsif not Is_Frozen (Tagged_Type) then
Error_Msg_N
("?not dispatching (must be defined in a package spec)", Subp);
return;
-- Now, we are sure that the scope is a package spec. If the subprogram
-- is declared after the freezing point ot the type that's an error
- elsif Is_Frozen (Tagged_Seen) and then not Has_Dispatching_Parent then
+ 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_Seen),
- Tagged_Seen);
+ Freeze_Node (Tagged_Type),
+ Tagged_Type);
return;
end if;
- Check_Controlling_Formals (Tagged_Seen, Subp);
+ Check_Controlling_Formals (Tagged_Type, Subp);
-- Now it should be a correct primitive operation, put it in the list
if Present (Old_Subp) then
Check_Subtype_Conformant (Subp, Old_Subp);
- Override_Dispatching_Operation (Tagged_Seen, Old_Subp, Subp);
+ if (Chars (Subp) = Name_Initialize
+ or else Chars (Subp) = Name_Adjust
+ or else Chars (Subp) = Name_Finalize)
+ and then Is_Controlled (Tagged_Type)
+ and then not Is_Visibly_Controlled (Tagged_Type)
+ then
+ Set_Is_Overriding_Operation (Subp, False);
+ Error_Msg_NE
+ ("operation does not override inherited&?", Subp, Subp);
+ else
+ Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
+ Set_Is_Overriding_Operation (Subp);
+ end if;
- else
- Add_Dispatching_Operation (Tagged_Seen, Subp);
+ -- If no old subprogram, then we add this as a dispatching operation,
+ -- but we avoid doing this if an error was posted, to prevent annoying
+ -- cascaded errors.
+
+ elsif not Error_Posted (Subp) then
+ 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);
- end if;
+ 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 : constant 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 TSS_Name_Type :=
+ (TSS_Deep_Initialize,
+ TSS_Deep_Adjust,
+ TSS_Deep_Finalize);
+
+ begin
+ -- Remove previous controlled function, which was constructed
+ -- and analyzed when the type was frozen. This requires
+ -- removing the body of the redefined primitive, as well as
+ -- its specification if needed (there is no spec created for
+ -- Deep_Initialize, see exp_ch3.adb). We must also dismantle
+ -- the exception information that may have been generated for
+ -- it when front end zero-cost tables are enabled.
+
+ 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);
+ end if;
+ end if;
+ end loop;
+
+ Build_Late_Proc (Tagged_Type, Chars (Subp));
+
+ -- 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,
+
+ 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;
------------------------------------------
Next_Elmt (Op2);
end loop;
- -- Operation is a new primitive.
+ -- Operation is a new primitive
Append_Elmt (Subp, New_Prim);
-
end Check_Operation_From_Incomplete_Type;
---------------------------------------
-- dispatching attributes here.
if not Is_Dispatching_Operation (Old_Subp) then
+
+ -- If the untagged type has no discriminants, and the full
+ -- view is constrained, there will be a spurious mismatch
+ -- of subtypes on the controlling arguments, because the tagged
+ -- type is the internal base type introduced in the derivation.
+ -- Use the original type to verify conformance, rather than the
+ -- base type.
+
+ if not Comes_From_Source (Tagged_Type)
+ and then Has_Discriminants (Tagged_Type)
+ then
+ declare
+ Formal : Entity_Id;
+ begin
+ Formal := First_Formal (Old_Subp);
+ while Present (Formal) loop
+ if Tagged_Type = Base_Type (Etype (Formal)) then
+ Tagged_Type := Etype (Formal);
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end;
+
+ if Tagged_Type = Base_Type (Etype (Old_Subp)) then
+ Tagged_Type := Etype (Old_Subp);
+ end if;
+ end if;
+
Check_Controlling_Formals (Tagged_Type, Old_Subp);
Set_Is_Dispatching_Operation (Old_Subp, True);
Set_DT_Position (Old_Subp, No_Uint);
-- Normal case
- elsif Is_Controlling_Actual (N) then
+ elsif Is_Controlling_Actual (N)
+ or else
+ (Nkind (Parent (N)) = N_Qualified_Expression
+ and then Is_Controlling_Actual (Parent (N)))
+ then
Typ := Etype (N);
if Is_Access_Type (Typ) then
if Nkind (N) = N_Attribute_Reference then
Typ := Etype (Prefix (N));
+
+ -- An allocator is dispatching if the type of qualified
+ -- expression is class_wide, in which case this is the
+ -- controlling type.
+
+ 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
+ if Is_Class_Wide_Type (Typ)
+ or else
+ (Nkind (Parent (N)) = N_Qualified_Expression
+ and then Is_Access_Type (Etype (N))
+ and then Is_Class_Wide_Type (Designated_Type (Etype (N))))
+ then
return N;
end if;
end if;
if not Has_Controlling_Result (Nam) then
return False;
+ -- An explicit dereference means that the call has already been
+ -- expanded and there is no tag to propagate.
+
+ elsif Nkind (N) = N_Explicit_Dereference then
+ return False;
+
-- If there are no actuals, the call is tag-indeterminate
elsif No (Parameter_Associations (Orig_Node)) then
else
Actual := First_Actual (Orig_Node);
-
while Present (Actual) loop
if Is_Controlling_Actual (Actual)
and then not Is_Tag_Indeterminate (Actual)
end loop;
return True;
-
end if;
elsif Nkind (Orig_Node) = N_Qualified_Expression then
return Is_Tag_Indeterminate (Expression (Orig_Node));
+ -- Case of a call to the Input attribute (possibly rewritten), which is
+ -- always tag-indeterminate except when its prefix is a Class attribute.
+
+ elsif Nkind (Orig_Node) = N_Attribute_Reference
+ and then
+ Get_Attribute_Id (Attribute_Name (Orig_Node)) = Attribute_Input
+ and then
+ Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference
+ then
+ return True;
else
return False;
end if;
Prev_Op : Entity_Id;
New_Op : Entity_Id)
is
- Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
+ 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
begin
+ -- Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
+ -- we do it unconditionally in Ada 95 now, since this is our pragma!)
+
+ if No_Return (Prev_Op) and then not No_Return (New_Op) then
+ Error_Msg_N ("procedure & must have No_Return pragma", New_Op);
+ Error_Msg_N ("\since overridden procedure has No_Return", New_Op);
+ end if;
+
-- Patch the primitive operation list
while Present (Op_Elmt)
return;
end if;
- Replace_Elmt (Op_Elmt, New_Op);
+ -- 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;
+
+ Set_Abstract_Interface_Alias (Prev_Op, E);
+ Set_Alias (Prev_Op, New_Op);
+ Set_Is_Internal (Prev_Op);
+ Set_Is_Hidden (Prev_Op);
+
+ -- Override predefined primitive operations
+
+ if Is_Predefined_Dispatching_Operation (Prev_Op) then
+ Replace_Elmt (Op_Elmt, New_Op);
+ return;
+ end if;
+
+ -- Check if this primitive operation was previously added for another
+ -- interface.
+
+ Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
+ Found := False;
+ while Present (Elmt) loop
+ if Node (Elmt) = New_Op then
+ Found := True;
+ exit;
+ 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 (Current_Scope))
+ if (not Is_Package_Or_Generic_Package (Current_Scope))
or else not In_Private_Part (Current_Scope)
then
-- Not a private primitive
else pragma Assert (Is_Inherited_Operation (Prev_Op));
-- Make the overriding operation into an alias of the implicit one.
- -- In this fashion a call from outside ends up calling the new
- -- body even if non-dispatching, and a call from inside calls the
- -- overriding operation because it hides the implicit one.
- -- To indicate that the body of Prev_Op is never called, set its
+ -- In this fashion a call from outside ends up calling the new body
+ -- even if non-dispatching, and a call from inside calls the
+ -- overriding operation because it hides the implicit one. To
+ -- indicate that the body of Prev_Op is never called, set its
-- dispatch table entity to Empty.
Set_Alias (Prev_Op, New_Op);
Call_Node := Expression (Parent (Entity (Actual)));
- -- Only other possibility is parenthesized or qualified expression
+ -- Only other possibilities are parenthesized or qualified expression,
+ -- or an expander-generated unchecked conversion of a function call to
+ -- a stream Input attribute.
else
Call_Node := Expression (Actual);
-- calls and would have to undo any expansion to an indirect call.
if not Java_VM then
- Expand_Dispatch_Call (Call_Node);
+ Expand_Dispatching_Call (Call_Node);
end if;
end Propagate_Tag;
OSDN Git Service
