mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-30 19:30:27 +08:00
Code Issues Packages Projects Releases Wiki Activity

sem_ch4.adb (Transform_Object_Operation): In a context off the form V (Obj.F)...

Browse Source 
2005-09-01  Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* sem_ch4.adb (Transform_Object_Operation): In a context off the form
	V (Obj.F), the rewriting does not involve the indexed component, but
	only the selected component itself.
	Do not apply the transformation if the analyzed node is an actual of a
	call to another subprogram.
	(Complete_Object_Operation): Retain the entity of the
	dispatching operation in the selector of the rewritten node. The
	entity will be used in the expansion of dispatching selects.
	(Analyze_One_Call): Improve location of the error message associated
	with interface.
	(Analyze_Selected_Component): No need to resolve prefix when it is a
	function call, resolution is done when parent node is resolved, as
	usual.
	(Analyze_One_Call): Add a flag to suppress analysis of the first actual,
	when attempting to resolve a call transformed from its object notation.
	(Try_Object_Operation, Transform_Object_Operastion): Avoid makind copies
	of the argument list for each interpretation of the operation.
	(Try_Object_Operation): The designated type of an access parameter may
	be an incomplete type obtained through a limited_with clause, in which
	case the primitive operations of the type are retrieved from its full
	view.
	(Analyze_Call): If this is an indirect call, and the return type of the
	access_to_subprogram is incomplete, use its full view if available.

From-SVN: r103882
This commit is contained in:
Ed Schonberg 2005-09-05 10:01:04 +02:00 committed by Arnaud Charlet
parent 9dfd2ff8dc
commit ec6078e39b
1 changed files with 219 additions and 237 deletions

456
gcc/ada/sem_ch4.adb

@ -25,7 +25,6 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
@ -97,10 +96,11 @@ package body Sem_Ch4 is
-- arguments, list possible interpretations.
procedure Analyze_One_Call
(N : Node_Id;
Nam : Entity_Id;
Report : Boolean;
Success : out Boolean);
(N : Node_Id;
Nam : Entity_Id;
Report : Boolean;
Success : out Boolean;
Skip_First : Boolean := False);
-- Check one interpretation of an overloaded subprogram name for
-- compatibility with the types of the actuals in a call. If there is a
-- single interpretation which does not match, post error if Report is
@ -111,6 +111,13 @@ package body Sem_Ch4 is
-- subprogram type constructed for an access_to_subprogram. If the actuals
-- are compatible with Nam, then Nam is added to the list of candidate
-- interpretations for N, and Success is set to True.
--
-- The flag Skip_First is used when analyzing a call that was rewritten
-- from object notation. In this case the first actual may have to receive
-- an explicit dereference, depending on the first formal of the operation
-- being called. The caller will have verified that the object is legal
-- for the call. If the remaining parameters match, the first parameter
-- will rewritten as a dereference if needed, prior to completing analysis.
procedure Check_Misspelled_Selector
(Prefix : Entity_Id;
@ -538,15 +545,6 @@ package body Sem_Ch4 is
Check_Restriction (No_Local_Allocators, N);
end if;
-- Ada 2005 (AI-231): Static checks
if Ada_Version >= Ada_05
and then (Null_Exclusion_Present (N)
or else Can_Never_Be_Null (Etype (N)))
then
Null_Exclusion_Static_Checks (N);
end if;
if Serious_Errors_Detected > Sav_Errs then
Set_Error_Posted (N);
Set_Etype (N, Any_Type);
@ -780,6 +778,20 @@ package body Sem_Ch4 is
Analyze_One_Call (N, Nam_Ent, True, Success);
-- If this is an indirect call, the return type of the access_to
-- subprogram may be an incomplete type. At the point of the call,
-- use the full type if available, and at the same time update
-- the return type of the access_to_subprogram.
if Success
and then Nkind (Nam) = N_Explicit_Dereference
and then Ekind (Etype (N)) = E_Incomplete_Type
and then Present (Full_View (Etype (N)))
then
Set_Etype (N, Full_View (Etype (N)));
Set_Etype (Nam_Ent, Etype (N));
end if;
else
-- An overloaded selected component must denote overloaded
-- operations of a concurrent type. The interpretations are
@ -1918,10 +1930,11 @@ package body Sem_Ch4 is
----------------------
procedure Analyze_One_Call
(N : Node_Id;
Nam : Entity_Id;
Report : Boolean;
Success : out Boolean)
(N : Node_Id;
Nam : Entity_Id;
Report : Boolean;
Success : out Boolean;
Skip_First : Boolean := False)
is
Actuals : constant List_Id := Parameter_Associations (N);
Prev_T : constant Entity_Id := Etype (N);
@ -2104,6 +2117,16 @@ package body Sem_Ch4 is
Actual := First_Actual (N);
Formal := First_Formal (Nam);
-- If we are analyzing a call rewritten from object notation,
-- skip first actual, which may be rewritten later as an
-- explicit dereference.
if Skip_First then
Next_Actual (Actual);
Next_Formal (Formal);
end if;
while Present (Actual) and then Present (Formal) loop
if Nkind (Parent (Actual)) /= N_Parameter_Association
or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal)
@ -2134,10 +2157,8 @@ package body Sem_Ch4 is
(Typ => Etype (Actual),
Iface => Etype (Etype (Formal)))
then
Error_Msg_Name_1 := Chars (Actual);
Error_Msg_Name_2 := Chars (Etype (Etype (Formal)));
Error_Msg_NE
("(Ada 2005) % does not implement interface %",
("(Ada 2005) does not implement interface }",
Actual, Etype (Etype (Formal)));
end if;
@ -2557,17 +2578,6 @@ package body Sem_Ch4 is
return;
else
-- Function calls that are prefixes of selected components must be
-- fully resolved in case we need to build an actual subtype, or
-- do some other operation requiring a fully resolved prefix.
-- Note: Resolving all Nkinds of nodes here doesn't work.
-- (Breaks 2129-008) ???.
if Nkind (Name) = N_Function_Call then
Resolve (Name);
end if;
Prefix_Type := Etype (Name);
end if;
@ -4845,9 +4855,7 @@ package body Sem_Ch4 is
Subprog : constant Node_Id := Selector_Name (N);
Actual : Node_Id;
Call_Node : Node_Id;
Call_Node_Case : Node_Id := Empty;
First_Actual : Node_Id;
New_Call_Node : Node_Id := Empty;
Node_To_Replace : Node_Id;
Obj_Type : Entity_Id := Etype (Obj);
@ -4855,31 +4863,30 @@ package body Sem_Ch4 is
(Call_Node : Node_Id;
Node_To_Replace : Node_Id;
Subprog : Node_Id);
-- Set Subprog as the name of Call_Node, replace Node_To_Replace with
-- Call_Node and reanalyze Node_To_Replace.
-- Make Subprog the name of Call_Node, replace Node_To_Replace with
-- Call_Node, insert the object (or its dereference) as the first actual
-- in the call, and complete the analysis of the call.
procedure Transform_Object_Operation
(Call_Node : out Node_Id;
First_Actual : Node_Id;
Node_To_Replace : out Node_Id;
Subprog : Node_Id);
-- Transform Object.Operation (...) to Operation (Object, ...)
-- Call_Node is the resulting subprogram call node, First_Actual is
-- either the object Obj or an explicit dereference of Obj in certain
-- cases, Node_To_Replace is either N or the parent of N, and Subprog
-- is the subprogram we are trying to match.
-- Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..)
-- Call_Node is the resulting subprogram call,
-- Node_To_Replace is either N or the parent of N, and Subprog
-- is a reference to the subprogram we are trying to match.
function Try_Class_Wide_Operation
(Call_Node : Node_Id;
Node_To_Replace : Node_Id) return Boolean;
-- Traverse all the ancestor types looking for a class-wide subprogram
-- that matches Subprog.
-- Traverse all ancestor types looking for a class-wide subprogram
-- for which the current operation is a valid non-dispatching call.
function Try_Primitive_Operation
(Call_Node : Node_Id;
Node_To_Replace : Node_Id) return Boolean;
-- Traverse the list of primitive subprograms looking for a subprogram
-- than matches Subprog.
-- Traverse the list of primitive subprograms looking for a dispatching
-- operation for which the current node is a valid call .
-------------------------------
-- Complete_Object_Operation --
@ -4890,9 +4897,30 @@ package body Sem_Ch4 is
Node_To_Replace : Node_Id;
Subprog : Node_Id)
is
First_Actual : Node_Id;
begin
Set_Name (Call_Node, New_Copy_Tree (Subprog));
Set_Analyzed (Call_Node, False);
First_Actual := First (Parameter_Associations (Call_Node));
Set_Name (Call_Node, Subprog);
if Nkind (N) = N_Selected_Component
and then not Inside_A_Generic
then
Set_Entity (Selector_Name (N), Entity (Subprog));
end if;
-- If need be, rewrite first actual as an explicit dereference
if not Is_Access_Type (Etype (First_Formal (Entity (Subprog))))
and then Is_Access_Type (Etype (Obj))
then
Rewrite (First_Actual,
Make_Explicit_Dereference (Sloc (Obj), Obj));
Analyze (First_Actual);
else
Rewrite (First_Actual, Obj);
end if;
Rewrite (Node_To_Replace, Call_Node);
Analyze (Node_To_Replace);
end Complete_Object_Operation;
@ -4903,51 +4931,45 @@ package body Sem_Ch4 is
procedure Transform_Object_Operation
(Call_Node : out Node_Id;
First_Actual : Node_Id;
Node_To_Replace : out Node_Id;
Subprog : Node_Id)
is
Actuals : List_Id;
Parent_Node : constant Node_Id := Parent (N);
Dummy : constant Node_Id := New_Copy (Obj);
-- Placeholder used as a first parameter in the call, replaced
-- eventually by the proper object.
Actuals : List_Id;
Actual : Node_Id;
begin
Actuals := New_List (New_Copy_Tree (First_Actual));
-- Common case covering 1) Call to a procedure and 2) Call to a
-- function that has some additional actuals.
if (Nkind (Parent_Node) = N_Function_Call
or else
Nkind (Parent_Node) = N_Procedure_Call_Statement)
-- Avoid recursive calls
-- N is a selected component node containing the name of the
-- subprogram. If N is not the name of the parent node we must
-- not replace the parent node by the new construct. This case
-- occurs when N is a parameterless call to a subprogram that
-- is an actual parameter of a call to another subprogram. For
-- example:
-- Some_Subprogram (..., Obj.Operation, ...)
and then N /= First (Parameter_Associations (Parent_Node))
and then Name (Parent_Node) = N
then
Node_To_Replace := Parent_Node;
-- Copy list of actuals in full before attempting to resolve call.
-- This is necessary to ensure that the chaining of named actuals
-- that happens during matching is done on a separate copy.
Actuals := Parameter_Associations (Parent_Node);
declare
Actual : Node_Id;
begin
Actual := First (Parameter_Associations (Parent_Node));
while Present (Actual) loop
declare
New_Actual : constant Node_Id := New_Copy_Tree (Actual);
begin
Append (New_Actual, Actuals);
if Nkind (Actual) = N_Function_Call
and then Is_Overloaded (Name (Actual))
then
Save_Interps (Name (Actual), Name (New_Actual));
end if;
end;
Next (Actual);
end loop;
end;
if Present (Actuals) then
Prepend (Dummy, Actuals);
else
Actuals := New_List (Dummy);
end if;
if Nkind (Parent_Node) = N_Procedure_Call_Statement then
Call_Node :=
@ -4956,8 +4978,6 @@ package body Sem_Ch4 is
Parameter_Associations => Actuals);
else
pragma Assert (Nkind (Parent_Node) = N_Function_Call);
Call_Node :=
Make_Function_Call (Loc,
Name => New_Copy_Tree (Subprog),
@ -4965,31 +4985,30 @@ package body Sem_Ch4 is
end if;
-- Before analysis, the function call appears as an
-- indexed component.
-- Before analysis, the function call appears as an indexed component
-- if there are no named associations.
elsif Nkind (Parent_Node) = N_Indexed_Component then
elsif Nkind (Parent_Node) = N_Indexed_Component
and then N = Prefix (Parent_Node)
then
Node_To_Replace := Parent_Node;
declare
Actual : Node_Id;
New_Act : Node_Id;
begin
Actual := First (Expressions (Parent_Node));
while Present (Actual) loop
New_Act := New_Copy_Tree (Actual);
Analyze (New_Act);
Append (New_Act, Actuals);
Next (Actual);
end loop;
end;
Actuals := Expressions (Parent_Node);
Actual := First (Actuals);
while Present (Actual) loop
Analyze (Actual);
Next (Actual);
end loop;
Prepend (Dummy, Actuals);
Call_Node :=
Make_Function_Call (Loc,
Name => New_Copy_Tree (Subprog),
Parameter_Associations => Actuals);
-- Parameterless call
-- Parameterless call: Obj.F is rewritten as F (Obj)
else
Node_To_Replace := N;
@ -4997,7 +5016,7 @@ package body Sem_Ch4 is
Call_Node :=
Make_Function_Call (Loc,
Name => New_Copy_Tree (Subprog),
Parameter_Associations => Actuals);
Parameter_Associations => New_List (Dummy));
end if;
end Transform_Object_Operation;
@ -5010,16 +5029,20 @@ package body Sem_Ch4 is
Node_To_Replace : Node_Id) return Boolean
is
Anc_Type : Entity_Id;
Dummy : Node_Id;
Hom : Entity_Id;
Hom_Ref : Node_Id;
Success : Boolean;
begin
-- Loop through ancestor types, traverse their homonym chains and
-- gather all interpretations of the subprogram.
-- Loop through ancestor types, traverse the homonym chain of the
-- subprogram, and try out those homonyms whose first formal has the
-- class-wide type of the ancestor.
-- Should we verify that it is declared in the same package as the
-- ancestor type ???
Anc_Type := Obj_Type;
loop
Hom := Current_Entity (Subprog);
while Present (Hom) loop
@ -5032,79 +5055,42 @@ package body Sem_Ch4 is
then
Hom_Ref := New_Reference_To (Hom, Loc);
-- When both the type of the object and the type of the
-- first formal of the primitive operation are tagged
-- access types, we use a node with the object as first
-- actual.
Set_Etype (Call_Node, Any_Type);
Set_Parent (Call_Node, Parent (Node_To_Replace));
if Is_Access_Type (Etype (Obj))
and then Ekind (Etype (First_Formal (Hom))) =
E_Anonymous_Access_Type
then
-- Allocate the node only once
Set_Name (Call_Node, Hom_Ref);
if not Present (Call_Node_Case) then
Analyze_Expression (Obj);
Set_Analyzed (Obj);
Analyze_One_Call
(N => Call_Node,
Nam => Hom,
Report => False,
Success => Success,
Skip_First => True);
Transform_Object_Operation (
Call_Node => Call_Node_Case,
First_Actual => Obj,
Node_To_Replace => Dummy,
Subprog => Subprog);
if Success then
Set_Etype (Call_Node_Case, Any_Type);
Set_Parent (Call_Node_Case, Parent (Node_To_Replace));
end if;
-- Reformat into the proper call
Set_Name (Call_Node_Case, Hom_Ref);
Complete_Object_Operation
(Call_Node => Call_Node,
Node_To_Replace => Node_To_Replace,
Subprog => Hom_Ref);
Analyze_One_Call (
N => Call_Node_Case,
Nam => Hom,
Report => False,
Success => Success);
if Success then
Complete_Object_Operation (
Call_Node => Call_Node_Case,
Node_To_Replace => Node_To_Replace,
Subprog => Hom_Ref);
return True;
end if;
-- ??? comment required
else
Set_Name (Call_Node, Hom_Ref);
Analyze_One_Call (
N => Call_Node,
Nam => Hom,
Report => False,
Success => Success);
if Success then
Complete_Object_Operation (
Call_Node => Call_Node,
Node_To_Replace => Node_To_Replace,
Subprog => Hom_Ref);
return True;
end if;
return True;
end if;
end if;
Hom := Homonym (Hom);
end loop;
-- Climb to ancestor type if there is one
-- Examine other ancestor types
exit when Etype (Anc_Type) = Anc_Type;
Anc_Type := Etype (Anc_Type);
end loop;
-- Nothing matched
return False;
end Try_Class_Wide_Operation;
@ -5116,12 +5102,44 @@ package body Sem_Ch4 is
(Call_Node : Node_Id;
Node_To_Replace : Node_Id) return Boolean
is
Dummy : Node_Id;
Elmt : Elmt_Id;
Prim_Op : Entity_Id;
Prim_Op_Ref : Node_Id;
Success : Boolean;
function Valid_First_Argument_Of (Op : Entity_Id) return Boolean;
-- Verify that the prefix, dereferenced if need be, is a valid
-- controlling argument in a call to Op. The remaining actuals
-- are checked in the subsequent call to Analyze_One_Call.
-----------------------------
-- Valid_First_Argument_Of --
-----------------------------
function Valid_First_Argument_Of (Op : Entity_Id) return Boolean is
Typ : constant Entity_Id := Etype (First_Formal (Op));
begin
-- Simple case
return Base_Type (Obj_Type) = Typ
-- Prefix can be dereferenced
or else
(Is_Access_Type (Obj_Type)
and then Designated_Type (Obj_Type) = Typ)
-- Formal is an access parameter, for which the object
-- can provide an access.
or else
(Ekind (Typ) = E_Anonymous_Access_Type
and then Designated_Type (Typ) = Obj_Type);
end Valid_First_Argument_Of;
-- Start of processing for Try_Primitive_Operation
begin
-- Look for the subprogram in the list of primitive operations
@ -5131,69 +5149,29 @@ package body Sem_Ch4 is
if Chars (Prim_Op) = Chars (Subprog)
and then Present (First_Formal (Prim_Op))
and then Valid_First_Argument_Of (Prim_Op)
then
Prim_Op_Ref := New_Reference_To (Prim_Op, Loc);
-- When both the type of the object and the type of the first
-- formal of the primitive operation are tagged access types,
-- we use a node with the object as first actual.
Set_Etype (Call_Node, Any_Type);
Set_Parent (Call_Node, Parent (Node_To_Replace));
if Is_Access_Type (Etype (Obj))
and then Ekind (Etype (First_Formal (Prim_Op))) =
E_Anonymous_Access_Type
then
-- Allocate the node only once
Set_Name (Call_Node, Prim_Op_Ref);
if not Present (Call_Node_Case) then
Analyze_Expression (Obj);
Set_Analyzed (Obj);
Analyze_One_Call
(N => Call_Node,
Nam => Prim_Op,
Report => False,
Success => Success,
Skip_First => True);
Transform_Object_Operation (
Call_Node => Call_Node_Case,
First_Actual => Obj,
Node_To_Replace => Dummy,
Subprog => Subprog);
if Success then
Complete_Object_Operation
(Call_Node => Call_Node,
Node_To_Replace => Node_To_Replace,
Subprog => Prim_Op_Ref);
Set_Etype (Call_Node_Case, Any_Type);
Set_Parent (Call_Node_Case, Parent (Node_To_Replace));
end if;
Set_Name (Call_Node_Case, Prim_Op_Ref);
Analyze_One_Call (
N => Call_Node_Case,
Nam => Prim_Op,
Report => False,
Success => Success);
if Success then
Complete_Object_Operation (
Call_Node => Call_Node_Case,
Node_To_Replace => Node_To_Replace,
Subprog => Prim_Op_Ref);
return True;
end if;
-- Comment required ???
else
Set_Name (Call_Node, Prim_Op_Ref);
Analyze_One_Call (
N => Call_Node,
Nam => Prim_Op,
Report => False,
Success => Success);
if Success then
Complete_Object_Operation (
Call_Node => Call_Node,
Node_To_Replace => Node_To_Replace,
Subprog => Prim_Op_Ref);
return True;
end if;
return True;
end if;
end if;
@ -5218,7 +5196,21 @@ package body Sem_Ch4 is
Obj_Type := Etype (Class_Wide_Type (Obj_Type));
end if;
-- Analyze the actuals in case of subprogram call
-- The type may have be obtained through a limited_with clause,
-- in which case the primitive operations are available on its
-- non-limited view.
if Ekind (Obj_Type) = E_Incomplete_Type
and then From_With_Type (Obj_Type)
then
Obj_Type := Non_Limited_View (Obj_Type);
end if;
if not Is_Tagged_Type (Obj_Type) then
return False;
end if;
-- Analyze the actuals if node is know to be a subprogram call
if Is_Subprg_Call and then N = Name (Parent (N)) then
Actual := First (Parameter_Associations (Parent (N)));
@ -5228,38 +5220,28 @@ package body Sem_Ch4 is
end loop;
end if;
-- If the object is of an Access type, explicit dereference is
-- required.
Analyze_Expression (Obj);
if Is_Access_Type (Etype (Obj)) then
First_Actual :=
Make_Explicit_Dereference (Sloc (Obj), Obj);
Set_Etype (First_Actual, Obj_Type);
else
First_Actual := Obj;
end if;
-- Build a subprogram call node, using a copy of Obj as its first
-- actual. This is a placeholder, to be replaced by an explicit
-- dereference when needed.
Analyze_Expression (First_Actual);
Set_Analyzed (First_Actual);
Transform_Object_Operation
(Call_Node => New_Call_Node,
Node_To_Replace => Node_To_Replace,
Subprog => Subprog);
-- Build a subprogram call node
Transform_Object_Operation (
Call_Node => Call_Node,
First_Actual => First_Actual,
Node_To_Replace => Node_To_Replace,
Subprog => Subprog);
Set_Etype (Call_Node, Any_Type);
Set_Parent (Call_Node, Parent (Node_To_Replace));
Set_Etype (New_Call_Node, Any_Type);
Set_Parent (New_Call_Node, Parent (Node_To_Replace));
return
Try_Primitive_Operation
(Call_Node => Call_Node,
(Call_Node => New_Call_Node,
Node_To_Replace => Node_To_Replace)
or else
Try_Class_Wide_Operation
(Call_Node => Call_Node,
(Call_Node => New_Call_Node,
Node_To_Replace => Node_To_Replace);
end Try_Object_Operation;