2005-09-01 Ed Schonberg <schonberg@adacore.com>

	* 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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@103888 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 4d3577e..f2835f6 100644 (file)
--- 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
 
@@ -4539,6 +4580,58 @@ package body Sem_Util is
    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 f21c93c..27f2abd 100644 (file)
--- 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