------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ D I S P -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2002 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- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- 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. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ 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 ----------------------- -- 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); -- Add New_Op in the list of primitive operations of Tagged_Type 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 -------------------------------- -- 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; ------------------------------- -- Check_Controlling_Formals -- ------------------------------- 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); -- Check that the parameter's nominal subtype statically -- matches the first subtype. 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; -- Verify that the restriction in E.2.2 (1) 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", 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); -- Check that the result subtype statically matches -- the first subtype. 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; -- 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; ---------------------------- -- Check_Controlling_Type -- ---------------------------- 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; -- 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)) then return Tagged_Type; else return Empty; end if; end Check_Controlling_Type; ---------------------------- -- Check_Dispatching_Call -- ---------------------------- procedure Check_Dispatching_Call (N : Node_Id) is Actual : Node_Id; Control : Node_Id := Empty; Func : Entity_Id; procedure Check_Dispatching_Context; -- If the call is tag-indeterminate and the entity being called is -- abstract, verify that the context is a call that will eventually -- provide a tag for dispatching, or has provided one already. ------------------------------- -- 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 -- private overriding of inherited abstract operation, -- call is legal 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; -- Start of processing for Check_Dispatching_Call begin -- Find a controlling argument, if any 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 -- Verify that no controlling arguments are statically tagged 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; -- can be anything elsif (Is_Dynamically_Tagged (Actual)) then null; -- valid parameter elsif Is_Tag_Indeterminate (Actual) then -- The tag is inherited from the enclosing call (the -- node we are currently analyzing). Explicitly expand -- the actual, since the previous call to Expand -- (from Resolve_Call) had no way of knowing about -- the required dispatching. 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; -- Mark call as a dispatching call Set_Controlling_Argument (N, Control); else -- The call is not dispatching, check that there isn't any -- tag indeterminate abstract call left Actual := First_Actual (N); while Present (Actual) loop if Is_Tag_Indeterminate (Actual) then -- Function call case if Nkind (Original_Node (Actual)) = N_Function_Call then Func := Entity (Name (Original_Node (Actual))); -- Only other possibility is a qualified expression whose -- consituent expression is itself a call. 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 -- If dispatching on result, the enclosing call, if any, will -- determine the controlling argument. Otherwise this is the -- primitive operation of the root type. Check_Dispatching_Context; end if; end Check_Dispatching_Call; --------------------------------- -- Check_Dispatching_Operation -- --------------------------------- 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); -- 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 -- 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)); 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_Type) and then not Comes_From_Source (Subp) and then not Has_Dispatching_Parent then return; -- The operation may be a child unit, whose scope is the defining -- package, but which is not a primitive operation of the type. elsif Is_Child_Unit (Subp) then return; -- If the subprogram is not defined in a package spec, the only case -- 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))) 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; -- If the type is already frozen, the overriding is not allowed -- except when Old_Subp is not a dispatching operation (which -- can occur when Old_Subp was inherited by an untagged type). -- However, a body with no previous spec freezes the type "after" -- its declaration, and therefore is a legal overriding (unless -- the type has already been frozen). Only the first such body -- is legal. 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 -- ??? The checks here for whether the type has been -- frozen prior to the new body are not complete. It's -- not simple to check frozenness at this point since -- the body has already caused the type to be prematurely -- frozen in Analyze_Declarations, but we're forced to -- recheck this here because of the odd rule interpretation -- that allows the overriding if the type wasn't frozen -- prior to the body. The freezing action should probably -- be delayed until after the spec is seen, but that's -- a tricky change to the delicate freezing code. -- Look at each declaration following the type up -- until the new subprogram body. If any of the -- declarations is a body then the type has been -- frozen already so the overriding primitive is -- illegal. 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 the subprogram doesn't follow in the list of -- declarations including the type then the type -- has definitely been frozen already and the body -- is illegal. 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 -- 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. 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; -- If the type is not frozen yet and we are not in the overridding -- case it looks suspiciously like an attempt to define a primitive -- operation. elsif not Is_Frozen (Tagged_Type) then Error_Msg_N ("?not dispatching (must be defined in a package spec)", Subp); return; -- When the type is frozen, it is legitimate to define a new -- non-primitive operation. else return; end if; -- 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_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); -- 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_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 -- 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 zero-cost is 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); 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)); -- 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; ------------------------------------------ -- Check_Operation_From_Incomplete_Type -- ------------------------------------------ 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; -- Check that Subp has the signature of an operation derived from Proc. -- Subp has an access parameter that designates Typ. ------------------ -- Derives_From -- ------------------ 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; -- Start of processing for Check_Operation_From_Incomplete_Type begin -- The operation may override an inherited one, or may be a new one -- altogether. The inherited operation will have been hidden by the -- current one at the point of the type derivation, so it does not -- appear in the list of primitive operations of the type. We have to -- find the proper place of insertion in the list of primitive opera- -- tions by iterating over the list for the parent type. 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; -- Operation is a new primitive. Append_Elmt (Subp, New_Prim); end Check_Operation_From_Incomplete_Type; --------------------------------------- -- Check_Operation_From_Private_View -- --------------------------------------- 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 Old_Subp isn't already marked as dispatching then -- this is the case of an operation of an untagged private -- type fulfilled by a tagged type that overrides an -- inherited dispatching operation, so we set the necessary -- dispatching attributes here. 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 the old subprogram is an explicit renaming of some other -- entity, it is not overridden by the inherited subprogram. -- Otherwise, update its alias and other attributes. if Present (Alias (Old_Subp)) and then Nkind (Unit_Declaration_Node (Old_Subp)) /= N_Subprogram_Renaming_Declaration then 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 -- an abstract operation, but the full type is derived from -- a descendant type and inherits a nonabstract version. 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; -------------------------- -- Find_Controlling_Arg -- -------------------------- 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; -- Dispatching on result case 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); -- Normal case elsif Is_Controlling_Actual (N) then Typ := Etype (N); if Is_Access_Type (Typ) then -- In the case of an Access attribute, use the type of -- the prefix, since in the case of an actual for an -- access parameter, the attribute's type may be of a -- specific designated type, even though the prefix -- type is class-wide. 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 return N; end if; end if; return Empty; end Find_Controlling_Arg; --------------------------- -- Find_Dispatching_Type -- --------------------------- 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; -- The subprogram may also be dispatching on result 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; --------------------------- -- Is_Dynamically_Tagged -- --------------------------- function Is_Dynamically_Tagged (N : Node_Id) return Boolean is begin return Find_Controlling_Arg (N) /= Empty; end Is_Dynamically_Tagged; -------------------------- -- Is_Tag_Indeterminate -- -------------------------- 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; -- If there are no actuals, the call is tag-indeterminate 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; -- one operand is dispatching 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; ------------------------------------ -- Override_Dispatching_Operation -- ------------------------------------ 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 -- Patch the primitive operation list while Present (Op_Elmt) and then Node (Op_Elmt) /= Prev_Op loop Next_Elmt (Op_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 return; end if; Replace_Elmt (Op_Elmt, New_Op); if (not Is_Package (Current_Scope)) or else not In_Private_Part (Current_Scope) then -- Not a private primitive null; 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 -- dispatch table entity to Empty. Set_Alias (Prev_Op, New_Op); Set_DTC_Entity (Prev_Op, Empty); return; end if; end Override_Dispatching_Operation; ------------------- -- Propagate_Tag -- ------------------- 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 rewritten as object declaration when stack-checking -- is enabled. Propagate tag to expression in declaration, which -- is original call. Call_Node := Expression (Parent (Entity (Actual))); -- Only other possibility is parenthesized or qualified expression else Call_Node := Expression (Actual); end if; -- Do not set the Controlling_Argument if already set. This happens -- in the special case of _Input (see Exp_Attr, case Input). 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; -- Expansion of dispatching calls is suppressed when Java_VM, because -- the JVM back end directly handles the generation of dispatching -- calls and would have to undo any expansion to an indirect call. if not Java_VM then Expand_Dispatch_Call (Call_Node); end if; end Propagate_Tag; end Sem_Disp;