[multiple changes]

2013-09-10  Yannick Moy  <moy@adacore.com>

	* sinfo.ads: Document splitting of pre/post in N_Contract description.

2013-09-10  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch4.adb (Expand_N_Op_Multiply): If the operation is of the
	form X * 2 ** N and it has been marked Is_Power_Of_2_For_Shift,
	add a mod operation if the result type is a binary modular type.

2013-09-10  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context): Add local
	variable Context.  Remove local variable Subp_Id. Start the
	context traversal from the current subprogram rather than the
	current scope. Update the scope traversal and error reporting.

2013-09-10  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch9.adb (Expand_N_Timed_Entry_Call): New procedure
	Rewrite_Triggering_Statements, to encapsulate the statements that
	follow the trigger of the entry call. This procedure is needed
	when the trigger is a dispatching call, because the expansion
	requires several copies of those statements. The procedure is
	more efficient, and preserves non-local references when the
	construct is within an instance.

From-SVN: r202454

5 files changed, 156 insertions, 24 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 86ca911..3c9757d 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,30 @@
+2013-09-10  Yannick Moy  <moy@adacore.com>
+
+	* sinfo.ads: Document splitting of pre/post in N_Contract description.
+
+2013-09-10  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch4.adb (Expand_N_Op_Multiply): If the operation is of the
+	form X * 2 ** N and it has been marked Is_Power_Of_2_For_Shift,
+	add a mod operation if the result type is a binary modular type.
+
+2013-09-10  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context): Add local
+	variable Context.  Remove local variable Subp_Id. Start the
+	context traversal from the current subprogram rather than the
+	current scope. Update the scope traversal and error reporting.
+
+2013-09-10  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch9.adb (Expand_N_Timed_Entry_Call): New procedure
+	Rewrite_Triggering_Statements, to encapsulate the statements that
+	follow the trigger of the entry call. This procedure is needed
+	when the trigger is a dispatching call, because the expansion
+	requires several copies of those statements. The procedure is
+	more efficient, and preserves non-local references when the
+	construct is within an instance.
+
 2013-09-10  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_ch12.adb (Analyze_Package_Instantiation): If the
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 79789b6..ffb49cb 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -8118,11 +8118,29 @@ package body Exp_Ch4 is
             return;
 
          else
-            Rewrite (N,
-              Make_Op_Shift_Left (Loc,
-                Left_Opnd  => Lop,
-                Right_Opnd =>
-                  Convert_To (Standard_Natural, Right_Opnd (Rop))));
+            --  If the result is modular, perform the reduction of the result
+            --  appropriately.
+
+            if Is_Modular_Integer_Type (Typ)
+              and then not Non_Binary_Modulus (Typ)
+            then
+               Rewrite (N,
+                Make_Op_And (Loc,
+                  Left_Opnd =>
+                    Make_Op_Shift_Left (Loc,
+                      Left_Opnd  => Lop,
+                      Right_Opnd =>
+                        Convert_To (Standard_Natural, Right_Opnd (Rop))),
+                  Right_Opnd =>
+                     Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
+            else
+               Rewrite (N,
+                 Make_Op_Shift_Left (Loc,
+                   Left_Opnd  => Lop,
+                   Right_Opnd =>
+                     Convert_To (Standard_Natural, Right_Opnd (Rop))));
+            end if;
+
             Analyze_And_Resolve (N, Typ);
             return;
          end if;
@@ -8130,11 +8148,26 @@ package body Exp_Ch4 is
       --  Same processing for the operands the other way round
 
       elsif Lp2 then
-         Rewrite (N,
-           Make_Op_Shift_Left (Loc,
-             Left_Opnd  => Rop,
-             Right_Opnd =>
-               Convert_To (Standard_Natural, Right_Opnd (Lop))));
+         if Is_Modular_Integer_Type (Typ)
+           and then not Non_Binary_Modulus (Typ)
+         then
+            Rewrite (N,
+             Make_Op_And (Loc,
+               Left_Opnd =>
+                 Make_Op_Shift_Left (Loc,
+                   Left_Opnd  => Rop,
+                   Right_Opnd =>
+                     Convert_To (Standard_Natural, Right_Opnd (Lop))),
+               Right_Opnd =>
+                  Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
+         else
+            Rewrite (N,
+              Make_Op_Shift_Left (Loc,
+                Left_Opnd  => Rop,
+                Right_Opnd =>
+                  Convert_To (Standard_Natural, Right_Opnd (Lop))));
+         end if;
+
          Analyze_And_Resolve (N, Typ);
          return;
       end if;
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index fdafd22..92ffa82 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -11986,9 +11986,11 @@ package body Exp_Ch9 is
    --    end;
 
    --  The triggering statement and the sequence of timed statements have not
-   --  been analyzed yet (see Analyzed_Timed_Entry_Call). They may contain
-   --  local declarations, and therefore the copies that are made during
-   --  expansion must be disjoint, as for any other inlining.
+   --  been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
+   --  global references if within an instantiation. To prevent duplication
+   --  between various uses of those statements, they are encapsulated into a
+   --  local procedure which is invoked multiple time when the trigger is a
+   --  dispatching call.
 
    procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
       Loc : constant Source_Ptr := Sloc (N);
@@ -12031,6 +12033,63 @@ package body Exp_Ch9 is
       P : Entity_Id;  --  Parameter block
       S : Entity_Id;  --  Primitive operation slot
 
+      procedure Rewrite_Triggering_Statements;
+      --  If the trigger is a dispatching call, the expansion inserts multiple
+      --  copies of the abortable part. This is both inefficient, and may lead
+      --  to duplicate definitions that the back-end will reject, when the
+      --  abortable part includes loops. This procedure rewrites the abortable
+      --  part into a call to a generated procedure.
+
+      -----------------------------------
+      -- Rewrite_Triggering_Statements --
+      -----------------------------------
+
+      procedure Rewrite_Triggering_Statements is
+         Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
+         Decl : Node_Id;
+         Stat : Node_Id;
+
+      begin
+         Decl :=
+           Make_Subprogram_Body (Loc,
+             Specification =>
+               Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc),
+             Declarations => New_List,
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc, E_Stats));
+
+         Append_To (Decls, Decl);
+
+         --  Adjust the scope of blocks in the procedure. Needed because blocks
+         --  generate declarations that are processed before other analysis
+         --  takes place, and their scope is already set. The backend depends
+         --  on the scope chain to determine the legality of some anonymous
+         --  types, and thus we must indicate that the block is within the new
+         --  procedure.
+
+         Stat := First (E_Stats);
+         while Present (Stat) loop
+            if Nkind (Stat) = N_Block_Statement then
+               Insert_Before (Stat,
+                 Make_Implicit_Label_Declaration (Sloc (Stat),
+                   Defining_Identifier =>
+                     Make_Defining_Identifier (
+                       Sloc (Stat), Chars (Identifier (Stat)))));
+            end if;
+
+            Next (Stat);
+         end loop;
+
+         --  Analyze (Decl);
+
+         --  Rewrite abortable part into a call to this procedure.
+
+         E_Stats :=
+           New_List
+             (Make_Procedure_Call_Statement (Loc,
+               Name => New_Occurrence_Of (Proc, Loc)));
+      end Rewrite_Triggering_Statements;
+
    begin
       --  Under the Ravenscar profile, timed entry calls are excluded. An error
       --  was already reported on spec, so do not attempt to expand the call.
@@ -12070,8 +12129,9 @@ package body Exp_Ch9 is
 
       if Is_Disp_Select then
          Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
-
          Decls := New_List;
+         Rewrite_Triggering_Statements;
+
          Stmts := New_List;
 
          --  Generate:
@@ -12280,7 +12340,7 @@ package body Exp_Ch9 is
          --       <timed-statements>
          --    end if;
 
-         N_Stats := Copy_Separate_List (E_Stats);
+         N_Stats := New_Copy_List_Tree (E_Stats);
 
          Prepend_To (N_Stats,
            Make_Implicit_If_Statement (N,
@@ -12320,7 +12380,7 @@ package body Exp_Ch9 is
          --    <dispatching-call>;
          --    <triggering-statements>
 
-         Lim_Typ_Stmts := Copy_Separate_List (E_Stats);
+         Lim_Typ_Stmts := New_Copy_List_Tree (E_Stats);
          Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call));
 
          --  Generate:
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index fd5b9a2..0d01b71 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -1514,22 +1514,24 @@ package body Sem_Prag is
            (Item    : Node_Id;
             Item_Id : Entity_Id)
          is
+            Context : Entity_Id;
             Dummy   : Boolean;
             Inputs  : Elist_Id := No_Elist;
             Outputs : Elist_Id := No_Elist;
-            Subp_Id : Entity_Id;
 
          begin
             --  Traverse the scope stack looking for enclosing subprograms
             --  subject to aspect/pragma Global.
 
-            Subp_Id := Scope (Current_Scope);
-            while Present (Subp_Id) and then Subp_Id /= Standard_Standard loop
-               if Is_Subprogram (Subp_Id)
-                 and then Has_Aspect (Subp_Id, Aspect_Global)
+            Context := Scope (Subp_Id);
+            while Present (Context)
+              and then Context /= Standard_Standard
+            loop
+               if Is_Subprogram (Context)
+                 and then Has_Aspect (Context, Aspect_Global)
                then
                   Collect_Subprogram_Inputs_Outputs
-                    (Subp_Id      => Subp_Id,
+                    (Subp_Id      => Context,
                      Subp_Inputs  => Inputs,
                      Subp_Outputs => Outputs,
                      Global_Seen  => Dummy);
@@ -1545,11 +1547,15 @@ package body Sem_Prag is
                         Item, Item_Id);
                      Error_Msg_NE
                        ("\item already appears as input of subprogram &",
-                        Item, Subp_Id);
+                        Item, Context);
+
+                     --  Stop the traversal once an error has been detected
+
+                     exit;
                   end if;
                end if;
 
-               Subp_Id := Scope (Subp_Id);
+               Context := Scope (Context);
             end loop;
          end Check_Mode_Restriction_In_Enclosing_Context;
 
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index e8c9805..b27e20b 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -7051,6 +7051,12 @@ package Sinfo is
       --  The pragmas can either come from source or be the byproduct of aspect
       --  expansion. The ordering in the list is of LIFO fashion.
 
+      --  Note that there might be multiple preconditions (resp.
+      --  postconditions) in this list, either because they come from
+      --  separate pragmas in the source, or because a Pre (resp. Post) aspect
+      --  specification has been broken into AND THEN sections. See Split_PPC
+      --  for details.
+
       --  Contract_Test_Cases contains a collection of pragmas that correspond
       --  to aspects/pragmas Contract_Cases and Test_Case. The ordering in the
       --  list is of LIFO fashion.