-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
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
+ -- 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 --
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.
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;
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.
+ -- 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))
+ 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
- if Present (Alias (Func))
- and then not Is_Abstract (Alias (Func))
- and then No (DTC_Entity (Func))
+ 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.
- Set_Entity (Name (N), Alias (Func));
+ Set_Entity (Name (N), Alias (Subp));
return;
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))
+ and then Is_Tagged_Type (Etype (Subp))
then
return;
Par := Parent (Par);
else
- Error_Msg_N
- ("call to abstract function must be dispatching", N);
+ 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;
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
+ 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;
Set_Is_Dispatching_Operation (Subp, False);
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
-- below will be bypassed. Makes sure that late declarations for
-- 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)
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);
-- 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!",
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;
Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
Set_Is_Overriding_Operation (Subp);
end if;
- else
+
+ -- 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;
then
Old_Spec := Corresponding_Spec (Old_Bod);
Set_Has_Completion (Old_Spec, False);
-
- if Exception_Mechanism = Front_End_ZCX_Exceptions 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;
Set_Alias (Old_Subp, Alias (Subp));
-- The derived subprogram should inherit the abstractness
-
-- of the parent subprogram (except in the case of a function
-- returning the type). This sets the abstractness properly
-- for cases where a private extension may have inherited
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;
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
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
