[Ada] Major code cleanup

2018-07-16  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* einfo.adb (Set_Is_Uplevel_Referenced_Entity): Flag can appear on
	loop parameters.
	* exp_ch7.adb (Check_Unnesting_Elaboration_Code): Handle subprogram
	bodies.
	* exp_ch9.adb (Reset_Scopes_To): Set the scopes of entities local to an
	entry body to be the corresponding generated subprogram, for correct
	analysis of uplevel references.
	* exp_unst.adb (Visit_Node): Handle properly binary and unary operators
	Ignore pragmas, fix component associations.
	(Register_Subprograms): Subprograms in synchronized types must be
	treated as reachable.

From-SVN: r262723

5 files changed, 184 insertions, 16 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 9644f6f..8a0250d 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,17 @@
+2018-07-16  Ed Schonberg  <schonberg@adacore.com>
+
+	* einfo.adb (Set_Is_Uplevel_Referenced_Entity): Flag can appear on
+	loop parameters.
+	* exp_ch7.adb (Check_Unnesting_Elaboration_Code): Handle subprogram
+	bodies.
+	* exp_ch9.adb (Reset_Scopes_To): Set the scopes of entities local to an
+	entry body to be the corresponding generated subprogram, for correct
+	analysis of uplevel references.
+	* exp_unst.adb (Visit_Node): Handle properly binary and unary operators
+	Ignore pragmas, fix component associations.
+	(Register_Subprograms): Subprograms in synchronized types must be
+	treated as reachable.
+
 2018-07-16  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_util.adb (Check_No_Hidden_State): Ignore internally-generated
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index c41dc30..f7742ec 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -5972,7 +5972,7 @@ package body Einfo is
    procedure Set_Is_Uplevel_Referenced_Entity (Id : E; V : B := True) is
    begin
       pragma Assert
-        (Ekind_In (Id, E_Constant, E_Variable, E_Discriminant)
+        (Ekind_In (Id, E_Constant, E_Variable, E_Loop_Parameter)
           or else Is_Formal (Id)
           or else Is_Type (Id));
       Set_Flag283 (Id, V);
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 663d974..d14cd7e 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -4048,6 +4048,9 @@ package body Exp_Ch7 is
                  and then Present (Identifier (Stat))
                then
                   Set_Scope (Entity (Identifier (Stat)), Elab_Proc);
+
+               elsif Nkind (Stat) = N_Subprogram_Body then
+                  Set_Scope (Defining_Entity (Stat), Elab_Proc);
                end if;
 
                Next (Stat);
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index ea03fe2..7d1ba35 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -474,6 +474,11 @@ package body Exp_Ch9 is
    --    ...
    --    <actualN> := P.<formalN>;
 
+   procedure Reset_Scopes_To (Proc_Body : Node_Id; E : Entity_Id);
+   --  Reset the scope of declarations and blocks at the top level of
+   --  Proc_Body to be E. Used after expanding entry bodies into their
+   --  corresponding procedures.
+
    function Trivial_Accept_OK return Boolean;
    --  If there is no DO-END block for an accept, or if the DO-END block has
    --  only null statements, then it is possible to do the Rendezvous with much
@@ -3558,6 +3563,7 @@ package body Exp_Ch9 is
       Bod_Stmts : List_Id;
       Complete  : Node_Id;
       Ohandle   : Node_Id;
+      Proc_Body : Node_Id;
 
       EH_Loc : Source_Ptr;
       --  Used for the exception handler, inserted at end of the body
@@ -3670,7 +3676,7 @@ package body Exp_Ch9 is
          --  Create body of entry procedure. The renaming declarations are
          --  placed ahead of the block that contains the actual entry body.
 
-         return
+         Proc_Body :=
            Make_Subprogram_Body (Loc,
              Specification              => Bod_Spec,
              Declarations               => Bod_Decls,
@@ -3699,6 +3705,9 @@ package body Exp_Ch9 is
                              Name =>
                                New_Occurrence_Of
                                  (RTE (RE_Get_GNAT_Exception), Loc)))))))));
+
+         Reset_Scopes_To (Proc_Body, Bod_Id);
+         return Proc_Body;
       end if;
    end Build_Protected_Entry;
 
@@ -10554,6 +10563,8 @@ package body Exp_Ch9 is
          Expr      : Node_Id;
          Call      : Node_Id;
 
+         --  Start of processing for Add_Accept
+
       begin
          if No (Ann) then
             Ann := Node (Last_Elmt (Accept_Address (Eent)));
@@ -10592,7 +10603,7 @@ package body Exp_Ch9 is
               Make_Defining_Identifier (Eloc,
                 New_External_Name (Chars (Ename), 'A', Num_Accept));
 
-            --  Link the acceptor to the original receiving entry
+            --  Link the acceptor to the original receiving entry.
 
             Set_Ekind           (PB_Ent, E_Procedure);
             Set_Receiving_Entry (PB_Ent, Eent);
@@ -10610,6 +10621,8 @@ package body Exp_Ch9 is
                 Handled_Statement_Sequence =>
                   Build_Accept_Body (Accept_Statement (Alt)));
 
+            Reset_Scopes_To (Proc_Body, PB_Ent);
+
             --  During the analysis of the body of the accept statement, any
             --  zero cost exception handler records were collected in the
             --  Accept_Handler_Records field of the N_Accept_Alternative node.
@@ -14713,6 +14726,63 @@ package body Exp_Ch9 is
       end if;
    end Parameter_Block_Unpack;
 
+   ---------------------
+   -- Reset_Scopes_To --
+   ---------------------
+
+   procedure Reset_Scopes_To (Proc_Body : Node_Id; E : Entity_Id) is
+
+      function Reset_Scope (N : Node_Id) return Traverse_Result;
+      --  Temporaries may have been declared during expansion of the
+      --  procedure alternative. Indicate that their scope is the new
+      --  body, to prevent generation of spurious uplevel references
+      --  for these entities.
+
+      procedure Reset_Scopes is new Traverse_Proc (Reset_Scope);
+
+      -----------------
+      -- Reset_Scope --
+      -----------------
+
+      function Reset_Scope (N : Node_Id) return Traverse_Result is
+         Decl : Node_Id;
+
+      begin
+         --  If this is a block statement with an Identifier, it forms
+         --  a scope, so we want to reset its scope but not look inside.
+
+         if Nkind (N) = N_Block_Statement and then Present (Identifier (N))
+         then
+            Set_Scope (Entity (Identifier (N)), E);
+            return Skip;
+
+         elsif Nkind (N) = N_Package_Declaration then
+            Set_Scope (Defining_Entity (N), E);
+            return Skip;
+
+         elsif N = Proc_Body then
+
+            --  Scan declarations
+
+            Decl := First (Declarations (N));
+            while Present (Decl) loop
+               Reset_Scopes (Decl);
+               Next (Decl);
+            end loop;
+
+         elsif N /= Proc_Body and then Nkind (N) in N_Proper_Body then
+            return Skip;
+         elsif Nkind (N) = N_Defining_Identifier then
+            Set_Scope (N, E);
+         end if;
+
+         return OK;
+      end Reset_Scope;
+
+   begin
+      Reset_Scopes (Proc_Body);
+   end Reset_Scopes_To;
+
    ----------------------
    -- Set_Discriminals --
    ----------------------
diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb
index 1ac9636..9a2a482 100644
--- a/gcc/ada/exp_unst.adb
+++ b/gcc/ada/exp_unst.adb
@@ -526,6 +526,23 @@ package body Exp_Unst is
                         end loop;
                      end;
 
+                  --  Binary operator cases. These can apply
+                  --  to arrays for which we may need bounds.
+
+                  elsif Nkind (N) in N_Binary_Op then
+                     Note_Uplevel_Bound (Left_Opnd (N),  Ref);
+                     Note_Uplevel_Bound (Right_Opnd (N), Ref);
+
+                  --  Unary operator case
+
+                  elsif Nkind (N) in N_Unary_Op then
+                     Note_Uplevel_Bound (Right_Opnd (N), Ref);
+
+                  --  Explicit dereference case
+
+                  elsif Nkind (N) = N_Explicit_Dereference then
+                     Note_Uplevel_Bound (Prefix (N), Ref);
+
                   --  Conversion case
 
                   elsif Nkind (N) = N_Type_Conversion then
@@ -694,12 +711,16 @@ package body Exp_Unst is
             procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id) is
                L : constant Nat := Get_Level (Subp, E);
 
+            --  Subprograms declared in tasks and protected types cannot
+            --  be eliminated because calls to them may be in other units,
+            --  so they must be treated as reachable.
+
             begin
                Subps.Append
                  ((Ent           => E,
                    Bod           => Bod,
                    Lev           => L,
-                   Reachable     => False,
+                   Reachable     => In_Synchronized_Unit (E),
                    Uplevel_Ref   => L,
                    Declares_AREC => False,
                    Uents         => No_Elist,
@@ -890,7 +911,9 @@ package body Exp_Unst is
                --  no relevant code generation.
 
                when N_Component_Association =>
-                  if No (Etype (Expression (N))) then
+                  if No (Expression (N))
+                    or else No (Etype (Expression (N)))
+                  then
                      return Skip;
                   end if;
 
@@ -932,6 +955,29 @@ package body Exp_Unst is
                      end;
                   end if;
 
+               --  For EQ/NE comparisons, we need the type of the operands
+               --  in order to do the comparison, which means we need the
+               --  bounds.
+
+               when N_Op_Eq | N_Op_Ne =>
+                  declare
+                     DT : Boolean := False;
+                  begin
+                     Check_Static_Type (Etype (Left_Opnd  (N)), Empty, DT);
+                     Check_Static_Type (Etype (Right_Opnd (N)), Empty, DT);
+                  end;
+
+               --  Likewise we need the sizes to compute how much to move in
+               --  an assignment.
+
+               when N_Assignment_Statement =>
+                  declare
+                     DT : Boolean := False;
+                  begin
+                     Check_Static_Type (Etype (Name       (N)), Empty, DT);
+                     Check_Static_Type (Etype (Expression (N)), Empty, DT);
+                  end;
+
                --  Record a subprogram. We record a subprogram body that acts
                --  as a spec. Otherwise we record a subprogram declaration,
                --  providing that it has a corresponding body we can get hold
@@ -1013,6 +1059,11 @@ package body Exp_Unst is
                      return Skip;
                   end if;
 
+               --  Pragmas and component declarations can be ignored.
+
+               when N_Pragma | N_Component_Declaration =>
+                  return Skip;
+
                --  Otherwise record an uplevel reference in a local
                --  identifier.
 
@@ -1036,7 +1087,8 @@ package body Exp_Unst is
                         --  references to global declarations.
 
                        and then
-                         (Ekind_In (Ent, E_Constant, E_Variable)
+                         (Ekind_In
+                           (Ent, E_Constant, E_Variable, E_Loop_Parameter)
 
                         --  Formals are interesting, but not if being used as
                         --  mere names of parameters for name notation calls.
@@ -1222,7 +1274,26 @@ package body Exp_Unst is
                      --  mark as requiring activation records.
 
                      exit when No (S);
-                     Subps.Table (Subp_Index (S)).Declares_AREC := True;
+
+                     declare
+                        SUBI : Subp_Entry renames Subps.Table (Subp_Index (S));
+                     begin
+                        SUBI.Declares_AREC := True;
+
+                        --  If this entity was marked reachable because it is
+                        --  in a task or protected type, there may not appear
+                        --  to be any calls to it, which would normally
+                        --  adjust the levels of the parent subprograms.
+                        --  So we need to be sure that the uplevel reference
+                        --  of that entity takes into account possible calls.
+
+                        if In_Synchronized_Unit (SUBF.Ent)
+                          and then SUBT.Lev < SUBI.Uplevel_Ref
+                        then
+                           SUBI.Uplevel_Ref := SUBT.Lev;
+                        end if;
+                     end;
+
                      exit when S = URJ.Callee;
                   end loop;
 
@@ -1272,13 +1343,6 @@ package body Exp_Unst is
                Decl : Node_Id;
 
             begin
-               --  Subprograms declared in tasks and protected types are
-               --  reachable and cannot be eliminated.
-
-               if In_Synchronized_Unit (STJ.Ent) then
-                  STJ.Reachable := True;
-               end if;
-
                --  Subprogram is reachable, copy and reset index
 
                if STJ.Reachable then
@@ -1796,7 +1860,8 @@ package body Exp_Unst is
                                  --  right after the declaration of ARECnP.
                                  --  For all other entities, we insert
                                  --  the assignment immediately after the
-                                 --  declaration of the entity.
+                                 --  declaration of the entity or after
+                                 --  the freeze node if present.
 
                                  --  Note: we don't need to mark the entity
                                  --  as being aliased, because the address
@@ -1805,6 +1870,10 @@ package body Exp_Unst is
 
                                  if Is_Formal (Ent) then
                                     Ins := Decl_ARECnP;
+
+                                 elsif Has_Delayed_Freeze (Ent) then
+                                    Ins := Freeze_Node (Ent);
+
                                  else
                                     Ins := Dec;
                                  end if;
@@ -1837,7 +1906,19 @@ package body Exp_Unst is
                                            New_Occurrence_Of (Ent, Loc),
                                          Attribute_Name => Attr));
 
-                                 Insert_After (Ins, Asn);
+                                 --  If we have a loop parameter, we have
+                                 --  to insert before the first statement
+                                 --  of the loop. Ins points to the
+                                 --  N_Loop_Parametrer_Specification.
+
+                                 if Ekind (Ent) = E_Loop_Parameter then
+                                    Ins := First (Statements
+                                                    (Parent (Parent (Ins))));
+                                    Insert_Before (Ins, Asn);
+
+                                 else
+                                    Insert_After (Ins, Asn);
+                                 end if;
 
                                  --  Analyze the assignment statement. We do
                                  --  not need to establish the relevant scope