From fe45e59ec7c0f225502471bf4202bee09efb63db Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Wed, 15 Feb 2006 10:44:37 +0100 Subject: [PATCH] sem_ch4.adb (Remove_Abstract_Interpretations): Even if there are no abstract interpretations on an operator... 2006-02-13 Ed Schonberg Javier Miranda * sem_ch4.adb (Remove_Abstract_Interpretations): Even if there are no abstract interpretations on an operator, remove interpretations that yield Address or a type derived from it, if one of the operands is an integer literal. (Try_Object_Operation.Try_Primitive_Operation, Try_Object_Operation.Try_Class_Wide_Operation): Set proper source location when creating the new reference to a primitive or class-wide operation as a part of rewriting a subprogram call. (Try_Primitive_Operations): If context requires a function, collect all interpretations after the first match, because there may be primitive operations of the same type with the same profile and different return types. From code reading. (Try_Primitive_Operation): Use the node kind to choose the proper operation when a function and a procedure have the same parameter profile. (Complete_Object_Operation): If formal is an access parameter and prefix is an object, rewrite as an Access reference, to match signature of primitive operation. (Find_Equality_Type, Find_One_Interp): Handle properly equality given by an expanded name with prefix Standard, when the operands are of an anonymous access type. (Remove_Abstract_Operations): If the operation is abstract because it is inherited by a user-defined type derived from Address, remove it as well from the set of candidate interpretations of an overloaded node. (Analyze_Membership_Op): Membership test not applicable to cpp-class types. From-SVN: r111092 --- gcc/ada/sem_ch4.adb | 201 ++++++++++++++++++++++++++++++++++---------- 1 file changed, 156 insertions(+), 45 deletions(-) diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index c35b3a74313..06669fb4a17 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -41,6 +41,7 @@ with Opt; use Opt; with Output; use Output; with Restrict; use Restrict; with Rident; use Rident; +with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; @@ -1870,6 +1871,12 @@ package body Sem_Ch4 is -- in any case. Set_Etype (N, Standard_Boolean); + + if Comes_From_Source (N) + and then Is_CPP_Class (Etype (Etype (Right_Opnd (N)))) + then + Error_Msg_N ("membership test not applicable to cpp-class types", N); + end if; end Analyze_Membership_Op; ---------------------- @@ -2040,7 +2047,7 @@ package body Sem_Ch4 is then return; - elsif not Present (Actuals) then + elsif No (Actuals) then -- If Normalize succeeds, then there are default parameters for -- all formals. @@ -4064,18 +4071,31 @@ package body Sem_Ch4 is -- universal, the context will impose the correct type. An anonymous -- type for a 'Access reference is also universal in this sense, as -- the actual type is obtained from context. + -- In Ada 2005, the equality operator for anonymous access types + -- is declared in Standard, and preference rules apply to it. - if Present (Scop) - and then not Defined_In_Scope (T1, Scop) - and then T1 /= Universal_Integer - and then T1 /= Universal_Real - and then T1 /= Any_Access - and then T1 /= Any_String - and then T1 /= Any_Composite - and then (Ekind (T1) /= E_Access_Subprogram_Type - or else Comes_From_Source (T1)) - then - return; + if Present (Scop) then + if Defined_In_Scope (T1, Scop) + or else T1 = Universal_Integer + or else T1 = Universal_Real + or else T1 = Any_Access + or else T1 = Any_String + or else T1 = Any_Composite + or else (Ekind (T1) = E_Access_Subprogram_Type + and then not Comes_From_Source (T1)) + then + null; + + elsif Ekind (T1) = E_Anonymous_Access_Type + and then Scop = Standard_Standard + then + null; + + else + -- The scope does not contain an operator for the type + + return; + end if; end if; -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95: @@ -4123,6 +4143,11 @@ package body Sem_Ch4 is if Etype (N) = Any_Type then Found := False; end if; + + elsif Scop = Standard_Standard + and then Ekind (T1) = E_Anonymous_Access_Type + then + Found := True; end if; end Try_One_Interp; @@ -4595,27 +4620,56 @@ package body Sem_Ch4 is if not Is_Type (It.Nam) and then Is_Abstract (It.Nam) and then not Is_Dispatching_Operation (It.Nam) - and then - (Ada_Version >= Ada_05 - or else Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (It.Nam)))) - then Abstract_Op := It.Nam; - Remove_Interp (I); - exit; + + -- In Ada 2005, this operation does not participate in Overload + -- resolution. If the operation is defined in in a predefined + -- unit, it is one of the operations declared abstract in some + -- variants of System, and it must be removed as well. + + if Ada_Version >= Ada_05 + or else Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (It.Nam))) + or else Is_Descendent_Of_Address (It.Typ) + then + Remove_Interp (I); + exit; + end if; end if; Get_Next_Interp (I, It); end loop; if No (Abstract_Op) then - return; + + -- If some interpretation yields an integer type, it is still + -- possible that there are address interpretations. Remove them + -- if one operand is a literal, to avoid spurious ambiguities + -- on systems where Address is a visible integer type. + + if Is_Overloaded (N) + and then Nkind (N) in N_Op + and then Is_Integer_Type (Etype (N)) + then + if Nkind (N) in N_Binary_Op then + if Nkind (Right_Opnd (N)) = N_Integer_Literal then + Remove_Address_Interpretations (Second_Op); + + elsif Nkind (Right_Opnd (N)) = N_Integer_Literal then + Remove_Address_Interpretations (First_Op); + end if; + end if; + end if; elsif Nkind (N) in N_Op then - -- Remove interpretations that treat literals as addresses. - -- This is never appropriate. + -- Remove interpretations that treat literals as addresses. This + -- is never appropriate, even when Address is defined as a visible + -- Integer type. The reason is that we would really prefer Address + -- to behave as a private type, even in this case, which is there + -- only to accomodate oddities of VMS address sizes. If Address is + -- a visible integer type, we get lots of overload ambiguities. if Nkind (N) in N_Binary_Op then declare @@ -4884,6 +4938,8 @@ package body Sem_Ch4 is Node_To_Replace : Node_Id; Subprog : Node_Id) is + Formal_Type : constant Entity_Id := + Etype (First_Formal (Entity (Subprog))); First_Actual : Node_Id; begin @@ -4898,12 +4954,26 @@ package body Sem_Ch4 is -- If need be, rewrite first actual as an explicit dereference - if not Is_Access_Type (Etype (First_Formal (Entity (Subprog)))) + if not Is_Access_Type (Formal_Type) and then Is_Access_Type (Etype (Obj)) then Rewrite (First_Actual, Make_Explicit_Dereference (Sloc (Obj), Obj)); Analyze (First_Actual); + + -- Conversely, if the formal is an access parameter and the + -- object is not, replace the actual with a 'Access reference. + -- Its analysis will check that the object is aliased. + + elsif Is_Access_Type (Formal_Type) + and then not Is_Access_Type (Etype (Obj)) + then + Rewrite (First_Actual, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Access, + Prefix => Relocate_Node (Obj))); + Analyze (First_Actual); + else Rewrite (First_Actual, Obj); end if; @@ -5040,7 +5110,7 @@ package body Sem_Ch4 is and then Etype (First_Formal (Hom)) = Class_Wide_Type (Anc_Type) then - Hom_Ref := New_Reference_To (Hom, Loc); + Hom_Ref := New_Reference_To (Hom, Sloc (Subprog)); Set_Etype (Call_Node, Any_Type); Set_Parent (Call_Node, Parent (Node_To_Replace)); @@ -5091,8 +5161,9 @@ package body Sem_Ch4 is is Elmt : Elmt_Id; Prim_Op : Entity_Id; - Prim_Op_Ref : Node_Id; - Success : Boolean; + Prim_Op_Ref : Node_Id := Empty; + Success : Boolean := False; + Op_Exists : Boolean := False; function Valid_First_Argument_Of (Op : Entity_Id) return Boolean; -- Verify that the prefix, dereferenced if need be, is a valid @@ -5128,7 +5199,9 @@ package body Sem_Ch4 is -- Start of processing for Try_Primitive_Operation begin - -- Look for the subprogram in the list of primitive operations + -- Look for subprograms in the list of primitive operations + -- The name must be identical, and the kind of call indicates + -- the expected kind of operation (function or procedure). Elmt := First_Elmt (Primitive_Operations (Obj_Type)); while Present (Elmt) loop @@ -5137,35 +5210,73 @@ 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) + and then + (Nkind (Call_Node) = N_Function_Call) + = (Ekind (Prim_Op) = E_Function) then - Prim_Op_Ref := New_Reference_To (Prim_Op, Loc); + -- If this primitive operation corresponds with an immediate + -- ancestor interface there is no need to add it to the list + -- of interpretations; the corresponding aliased primitive is + -- also in this list of primitive operations and will be + -- used instead. + + if Present (Abstract_Interface_Alias (Prim_Op)) + and then Present (DTC_Entity (Alias (Prim_Op))) + and then Etype (DTC_Entity (Alias (Prim_Op))) = RTE (RE_Tag) + then + goto Continue; + end if; + + if not Success then + Prim_Op_Ref := New_Reference_To (Prim_Op, Sloc (Subprog)); - Set_Etype (Call_Node, Any_Type); - Set_Parent (Call_Node, Parent (Node_To_Replace)); + Set_Etype (Call_Node, Any_Type); + Set_Parent (Call_Node, Parent (Node_To_Replace)); - 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, - Skip_First => True); + 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 + Op_Exists := True; - return True; + -- If the operation is a procedure call, there can only + -- be one candidate and we found it. If it is a function + -- we must collect all interpretations, because there + -- may be several primitive operations that differ only + -- in the return type. + + if Nkind (Call_Node) = N_Procedure_Call_Statement then + exit; + end if; + end if; + + elsif Ekind (Prim_Op) = E_Function then + + -- Collect remaining function interpretations, to be + -- resolved from context. + + Add_One_Interp (Prim_Op_Ref, Prim_Op, Etype (Prim_Op)); end if; end if; + <> Next_Elmt (Elmt); end loop; - return False; + if Op_Exists then + Complete_Object_Operation + (Call_Node => Call_Node, + Node_To_Replace => Node_To_Replace, + Subprog => Prim_Op_Ref); + end if; + + return Op_Exists; end Try_Primitive_Operation; -- Start of processing for Try_Object_Operation -- 2.30.2