From ec6078e39bea99dc01b635d24db203caf7d26de5 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Mon, 5 Sep 2005 10:01:04 +0200 Subject: [PATCH] sem_ch4.adb (Transform_Object_Operation): In a context off the form V (Obj.F)... 2005-09-01 Ed Schonberg Javier Miranda * 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 --- gcc/ada/sem_ch4.adb | 456 +++++++++++++++++++++----------------------- 1 file changed, 219 insertions(+), 237 deletions(-) diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 8ce93e7ae54..1f8eb2155c3 100644 --- a/gcc/ada/sem_ch4.adb +++ b/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. - - 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 := @@ -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. - - 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; @@ -5116,84 +5102,76 @@ 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; - 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; @@ -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. - - 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; -- 2.30.2