From 2c867f5a52a8fbe19640847244e0251754fd85b2 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Mon, 5 Sep 2005 10:03:48 +0200 Subject: [PATCH] sem_util.ads, [...] (Gather_Components): Omit interface tags from the list of required components. 2005-09-01 Ed Schonberg * sem_util.ads, sem_util.adb (Gather_Components): Omit interface tags from the list of required components. (Is_Controlling_Limited_Procedure): Determine whether an entity is a primitive procedure of a limited interface with a controlling first parameter. (Is_Renamed_Entry): Determine whether an entry is a procedure renaming of an entry. (Safe_To_Capture_Value): A value (such as non_null) is not safe to capture if it is generated in the second operand of a short-circuit operation. Do not capture values for variables with address clauses. (Is_Object_Reference): Treat a function call as an object reference only if its type is not Standard_Void_Type. From-SVN: r103888 --- gcc/ada/sem_util.adb | 162 ++++++++++++++++++++++++++++++++++--------- gcc/ada/sem_util.ads | 11 ++- 2 files changed, 137 insertions(+), 36 deletions(-) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4d3577e8ea0..f2835f67461 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2206,16 +2206,21 @@ package body Sem_Util is while Present (Comp_Item) loop - -- Skip the tag of a tagged record, as well as all items - -- that are not user components (anonymous types, rep clauses, - -- Parent field, controller field). - - if Nkind (Comp_Item) = N_Component_Declaration - and then Chars (Defining_Identifier (Comp_Item)) /= Name_uTag - and then Chars (Defining_Identifier (Comp_Item)) /= Name_uParent - and then Chars (Defining_Identifier (Comp_Item)) /= Name_uController - then - Append_Elmt (Defining_Identifier (Comp_Item), Into); + -- Skip the tag of a tagged record, the interface tags, as well + -- as all items that are not user components (anonymous types, + -- rep clauses, Parent field, controller field). + + if Nkind (Comp_Item) = N_Component_Declaration then + declare + Comp : constant Entity_Id := Defining_Identifier (Comp_Item); + begin + if not Is_Tag (Comp) + and then Chars (Comp) /= Name_uParent + and then Chars (Comp) /= Name_uController + then + Append_Elmt (Comp, Into); + end if; + end; end if; Next (Comp_Item); @@ -3438,6 +3443,41 @@ package body Sem_Util is end if; end Is_Atomic_Object; + -------------------------------------- + -- Is_Controlling_Limited_Procedure -- + -------------------------------------- + + function Is_Controlling_Limited_Procedure + (Proc_Nam : Entity_Id) return Boolean + is + Param_Typ : Entity_Id; + + begin + -- Proc_Nam was found to be a primitive operation of a limited interface + + if Ekind (Proc_Nam) = E_Procedure then + Param_Typ := Etype (Parameter_Type (First (Parameter_Specifications ( + Parent (Proc_Nam))))); + return + Is_Interface (Param_Typ) + and then Is_Limited_Record (Param_Typ); + + -- In this case where an Itype was created, the procedure call has been + -- rewritten. + + elsif Present (Associated_Node_For_Itype (Proc_Nam)) + and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) + then + Param_Typ := Etype (First (Parameter_Associations ( + Associated_Node_For_Itype (Proc_Nam)))); + return + Is_Interface (Param_Typ) + and then Is_Limited_Record (Param_Typ); + end if; + + return False; + end Is_Controlling_Limited_Procedure; + ---------------------------------------------- -- Is_Dependent_Component_Of_Mutable_Object -- ---------------------------------------------- @@ -4078,10 +4118,11 @@ package body Sem_Util is Is_Object_Reference (Prefix (N)) or else Is_Access_Type (Etype (Prefix (N))); - -- In Ada95, a function call is a constant object + -- In Ada95, a function call is a constant object; a procedure + -- call is not. when N_Function_Call => - return True; + return Etype (N) /= Standard_Void_Type; -- A reference to the stream attribute Input is a function call @@ -4538,6 +4579,58 @@ package body Sem_Util is return False; end Is_Remote_Call; + ---------------------- + -- Is_Renamed_Entry -- + ---------------------- + + function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is + Orig_Node : Node_Id := Empty; + Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); + + function Is_Entry (Nam : Node_Id) return Boolean; + -- Determine whether Nam is an entry. Traverse selectors + -- if there are nested selected components. + + -------------- + -- Is_Entry -- + -------------- + + function Is_Entry (Nam : Node_Id) return Boolean is + begin + if Nkind (Nam) = N_Selected_Component then + return Is_Entry (Selector_Name (Nam)); + end if; + + return Ekind (Entity (Nam)) = E_Entry; + end Is_Entry; + + -- Start of processing for Is_Renamed_Entry + + begin + if Present (Alias (Proc_Nam)) then + Subp_Decl := Parent (Parent (Alias (Proc_Nam))); + end if; + + -- Look for a rewritten subprogram renaming declaration + + if Nkind (Subp_Decl) = N_Subprogram_Declaration + and then Present (Original_Node (Subp_Decl)) + then + Orig_Node := Original_Node (Subp_Decl); + end if; + + -- The rewritten subprogram is actually an entry + + if Present (Orig_Node) + and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration + and then Is_Entry (Name (Orig_Node)) + then + return True; + end if; + + return False; + end Is_Renamed_Entry; + ---------------------- -- Is_Selector_Name -- ---------------------- @@ -6096,8 +6189,14 @@ package body Sem_Util is -- Skip volatile and aliased variables, since funny things might -- be going on in these cases which we cannot necessarily track. + -- Also skip any variable for which an address clause is given. + + -- Should we have a flag Has_Address_Clause ??? - if Treat_As_Volatile (Ent) or else Is_Aliased (Ent) then + if Treat_As_Volatile (Ent) + or else Is_Aliased (Ent) + or else Present (Address_Clause (Ent)) + then return False; end if; @@ -6130,28 +6229,27 @@ package body Sem_Util is -- or an exception handler). declare - P : Node_Id; + Desc : Node_Id; + P : Node_Id; begin - P := Parent (N); + Desc := N; + P := Parent (N); while Present (P) loop if Nkind (P) = N_If_Statement - or else - Nkind (P) = N_Case_Statement - or else - Nkind (P) = N_Exception_Handler - or else - Nkind (P) = N_Selective_Accept - or else - Nkind (P) = N_Conditional_Entry_Call - or else - Nkind (P) = N_Timed_Entry_Call - or else - Nkind (P) = N_Asynchronous_Select + or else Nkind (P) = N_Case_Statement + or else (Nkind (P) = N_And_Then and then Desc = Right_Opnd (P)) + or else (Nkind (P) = N_Or_Else and then Desc = Right_Opnd (P)) + or else Nkind (P) = N_Exception_Handler + or else Nkind (P) = N_Selective_Accept + or else Nkind (P) = N_Conditional_Entry_Call + or else Nkind (P) = N_Timed_Entry_Call + or else Nkind (P) = N_Asynchronous_Select then return False; else - P := Parent (P); + Desc := P; + P := Parent (P); end if; end loop; end; @@ -6298,12 +6396,11 @@ package body Sem_Util is return; end if; - Val_Actual := Val; - -- A special situation arises for derived operations, where we want -- to do the check against the parent (since the Sloc of the derived -- operation points to the derived type declaration itself). + Val_Actual := Val; while not Comes_From_Source (Val_Actual) and then Nkind (Val_Actual) in N_Entity and then (Ekind (Val_Actual) = E_Enumeration_Literal @@ -6489,7 +6586,7 @@ package body Sem_Util is ----------------------- procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is - Ent : Entity_Id := First_Entity (From); + Ent : Entity_Id := First_Entity (From); begin if No (Ent) then @@ -6522,7 +6619,6 @@ package body Sem_Util is begin Comp := First_Entity (Ent); - while Present (Comp) loop Set_Is_Public (Comp); Next_Entity (Comp); @@ -6635,9 +6731,7 @@ package body Sem_Util is else Get_First_Interp (Opnd, Index, It); - while Present (It.Typ) loop - if It.Typ = Universal_Integer or else It.Typ = Universal_Real then diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index f21c93cdfc3..27f2abd9708 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -456,6 +456,11 @@ package Sem_Util is -- Determines if the given node denotes an atomic object in the sense -- of the legality checks described in RM C.6(12). + function Is_Controlling_Limited_Procedure + (Proc_Nam : Entity_Id) return Boolean; + -- Ada 2005 (AI-345): Determine whether Proc_Nam is a primitive procedure + -- of a limited interface with a controlling first parameter. + function Is_Dependent_Component_Of_Mutable_Object (Object : Node_Id) return Boolean; -- Returns True if Object is the name of a subcomponent that @@ -560,6 +565,9 @@ package Sem_Util is function Is_Remote_Call (N : Node_Id) return Boolean; -- Return True if N denotes a potentially remote call + function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean; + -- Return True if Proc_Nam is a procedure renaming of an entry + function Is_Selector_Name (N : Node_Id) return Boolean; -- Given an N_Identifier node N, determines if it is a Selector_Name. -- As described in Sinfo, Selector_Names are special because they @@ -735,8 +743,7 @@ package Sem_Util is function Safe_To_Capture_Value (N : Node_Id; - Ent : Entity_Id) - return Boolean; + Ent : Entity_Id) return Boolean; -- The caller is interested in capturing a value (either the current -- value, or an indication that the value is non-null) for the given -- entity Ent. This value can only be captured if sequential execution -- 2.30.2