993 lines
34 KiB
Ada
993 lines
34 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- S E M _ D I S P --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- $Revision: 1.114 $
|
|
-- --
|
|
-- Copyright (C) 1992-2001 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. --
|
|
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Atree; use Atree;
|
|
with Debug; use Debug;
|
|
with Elists; use Elists;
|
|
with Einfo; use Einfo;
|
|
with Exp_Disp; use Exp_Disp;
|
|
with Errout; use Errout;
|
|
with Hostparm; use Hostparm;
|
|
with Nlists; use Nlists;
|
|
with Output; use Output;
|
|
with Sem_Ch6; use Sem_Ch6;
|
|
with Sem_Eval; use Sem_Eval;
|
|
with Sem_Util; use Sem_Util;
|
|
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
|
|
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
|
|
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 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_Seen : 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_Seen := 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_Seen) then
|
|
return;
|
|
|
|
-- The subprograms build internally after the freezing point (such as
|
|
-- the Init procedure) are not primitives
|
|
|
|
elsif Is_Frozen (Tagged_Seen)
|
|
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_Seen))
|
|
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_Seen));
|
|
|
|
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_Seen) 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_Seen) 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);
|
|
return;
|
|
end if;
|
|
|
|
Check_Controlling_Formals (Tagged_Seen, 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);
|
|
|
|
else
|
|
Add_Dispatching_Operation (Tagged_Seen, Subp);
|
|
end if;
|
|
|
|
Set_Is_Dispatching_Operation (Subp, True);
|
|
|
|
if not Body_Is_Last_Primitive then
|
|
Set_DT_Position (Subp, No_Uint);
|
|
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));
|
|
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;
|