------------------------------------------------------------------------------
with Atree; use Atree;
-with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
-- 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
-- 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;
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);
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
----------------------
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);
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)
(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;
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;
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);
(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 --
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;
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.
-
- 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;
+ Actuals := Parameter_Associations (Parent_Node);
- 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 :=
Parameter_Associations => Actuals);
else
- pragma Assert (Nkind (Parent_Node) = N_Function_Call);
-
Call_Node :=
Make_Function_Call (Loc,
Name => New_Copy_Tree (Subprog),
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;
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;
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
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.
-
- if Is_Access_Type (Etype (Obj))
- and then Ekind (Etype (First_Formal (Hom))) =
- E_Anonymous_Access_Type
- then
- -- Allocate the node only once
-
- if not Present (Call_Node_Case) then
- Analyze_Expression (Obj);
- Set_Analyzed (Obj);
-
- Transform_Object_Operation (
- Call_Node => Call_Node_Case,
- First_Actual => Obj,
- Node_To_Replace => Dummy,
- Subprog => Subprog);
-
- Set_Etype (Call_Node_Case, Any_Type);
- Set_Parent (Call_Node_Case, Parent (Node_To_Replace));
- end if;
-
- Set_Name (Call_Node_Case, 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);
+ Set_Etype (Call_Node, Any_Type);
+ Set_Parent (Call_Node, Parent (Node_To_Replace));
- return True;
- end if;
+ Set_Name (Call_Node, Hom_Ref);
- -- ??? comment required
+ Analyze_One_Call
+ (N => Call_Node,
+ Nam => Hom,
+ Report => False,
+ Success => Success,
+ Skip_First => True);
- else
- Set_Name (Call_Node, Hom_Ref);
+ if Success then
- Analyze_One_Call (
- N => Call_Node,
- Nam => Hom,
- Report => False,
- Success => Success);
+ -- Reformat into the proper call
- if Success then
- Complete_Object_Operation (
- Call_Node => Call_Node,
- Node_To_Replace => Node_To_Replace,
- Subprog => Hom_Ref);
+ 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;
(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;
- begin
- -- Look for the subprogram in the list of primitive operations
+ 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.
- Elmt := First_Elmt (Primitive_Operations (Obj_Type));
- while Present (Elmt) loop
- Prim_Op := Node (Elmt);
+ -----------------------------
+ -- Valid_First_Argument_Of --
+ -----------------------------
- if Chars (Prim_Op) = Chars (Subprog)
- and then Present (First_Formal (Prim_Op))
- then
- Prim_Op_Ref := New_Reference_To (Prim_Op, Loc);
+ function Valid_First_Argument_Of (Op : Entity_Id) return Boolean is
+ Typ : constant Entity_Id := Etype (First_Formal (Op));
- -- 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.
+ begin
+ -- Simple case
- if Is_Access_Type (Etype (Obj))
- and then Ekind (Etype (First_Formal (Prim_Op))) =
- E_Anonymous_Access_Type
- then
- -- Allocate the node only once
+ return Base_Type (Obj_Type) = Typ
- if not Present (Call_Node_Case) then
- Analyze_Expression (Obj);
- Set_Analyzed (Obj);
+ -- Prefix can be dereferenced
- Transform_Object_Operation (
- Call_Node => Call_Node_Case,
- First_Actual => Obj,
- Node_To_Replace => Dummy,
- Subprog => Subprog);
+ or else
+ (Is_Access_Type (Obj_Type)
+ and then Designated_Type (Obj_Type) = Typ)
- Set_Etype (Call_Node_Case, Any_Type);
- Set_Parent (Call_Node_Case, Parent (Node_To_Replace));
- end if;
+ -- Formal is an access parameter, for which the object
+ -- can provide an access.
- Set_Name (Call_Node_Case, Prim_Op_Ref);
+ or else
+ (Ekind (Typ) = E_Anonymous_Access_Type
+ and then Designated_Type (Typ) = Obj_Type);
+ end Valid_First_Argument_Of;
- Analyze_One_Call (
- N => Call_Node_Case,
- Nam => Prim_Op,
- Report => False,
- Success => Success);
+ -- Start of processing for Try_Primitive_Operation
- if Success then
- Complete_Object_Operation (
- Call_Node => Call_Node_Case,
- Node_To_Replace => Node_To_Replace,
- Subprog => Prim_Op_Ref);
+ begin
+ -- Look for the subprogram in the list of primitive operations
- return True;
- end if;
+ Elmt := First_Elmt (Primitive_Operations (Obj_Type));
+ while Present (Elmt) loop
+ Prim_Op := Node (Elmt);
+
+ 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);
- -- Comment required ???
+ Set_Etype (Call_Node, Any_Type);
+ Set_Parent (Call_Node, Parent (Node_To_Replace));
- else
- Set_Name (Call_Node, Prim_Op_Ref);
+ Set_Name (Call_Node, Prim_Op_Ref);
- Analyze_One_Call (
- N => Call_Node,
- Nam => Prim_Op,
- Report => False,
- Success => Success);
+ Analyze_One_Call
+ (N => Call_Node,
+ Nam => Prim_Op,
+ Report => False,
+ Success => Success,
+ Skip_First => True);
- if Success then
- Complete_Object_Operation (
- Call_Node => Call_Node,
- Node_To_Replace => Node_To_Replace,
- Subprog => Prim_Op_Ref);
+ 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;
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)));
end loop;
end if;
- -- If the object is of an Access type, explicit dereference is
- -- required.
-
- 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;
-
- Analyze_Expression (First_Actual);
- Set_Analyzed (First_Actual);
+ Analyze_Expression (Obj);
- -- Build a subprogram call node
+ -- 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.
- Transform_Object_Operation (
- Call_Node => Call_Node,
- First_Actual => First_Actual,
- Node_To_Replace => Node_To_Replace,
- Subprog => Subprog);
+ Transform_Object_Operation
+ (Call_Node => New_Call_Node,
+ 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;
projects / platform / upstream / gcc.git / commitdiff