[multiple changes]

2016-10-13  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch6.adb (Analyze_Expression_Function):
	Remove the aspects of the original expression function has been
	rewritten into a subprogram declaration or a body. Reinsert the
	aspects once they have been analyzed.

2016-10-13  Tristan Gingold  <gingold@adacore.com>

	* exp_ch9.adb (Expand_N_Asynchronous_Select): Return immediately
	on restricted profile.

2016-10-13  Javier Miranda  <miranda@adacore.com>

	* sem_prag.adb
	(Process_Compile_Time_Warning_Or_Error): Register the pragma
	for its validation after the backend has been called only if its
	expression has some occurrence of attributes 'size or 'alignment
	* table.ads (Release_Threshold): New formal.
	(Release): Adding documentation of its new functionality.
	* table.adb (Release): Extend its functionality with a
	Release_Threshold.
	* nlists.adb (Next_Node table): Set its Release_Threshold.
	* atree.adb (Orig_Nodes table): Set its Release_Threshold.
	* atree.ads (Nodes table): Set its Release_Threshold.
	(Flags table): Set its Release_Threshold.
	* alloc.ads (Nodes_Release_Threshold): New constant declaration.
	(Orig_Nodes_Release_Threshold): New constant declaration.
	* debug.adb (switch d.9): Left free.
	* gnat1drv.adb (Post_Compilation_Validation_Checks): Enable
	validation of pragmas Compile_Time_Error and Compile_Time_Warning.

From-SVN: r241117

12 files changed, 177 insertions, 46 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 71014fb..b2c29fd 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,37 @@
 2016-10-13  Hristian Kirtchev  <kirtchev@adacore.com>
 
+	* sem_ch6.adb (Analyze_Expression_Function):
+	Remove the aspects of the original expression function has been
+	rewritten into a subprogram declaration or a body. Reinsert the
+	aspects once they have been analyzed.
+
+2016-10-13  Tristan Gingold  <gingold@adacore.com>
+
+	* exp_ch9.adb (Expand_N_Asynchronous_Select): Return immediately
+	on restricted profile.
+
+2016-10-13  Javier Miranda  <miranda@adacore.com>
+
+	* sem_prag.adb
+	(Process_Compile_Time_Warning_Or_Error): Register the pragma
+	for its validation after the backend has been called only if its
+	expression has some occurrence of attributes 'size or 'alignment
+	* table.ads (Release_Threshold): New formal.
+	(Release): Adding documentation of its new functionality.
+	* table.adb (Release): Extend its functionality with a
+	Release_Threshold.
+	* nlists.adb (Next_Node table): Set its Release_Threshold.
+	* atree.adb (Orig_Nodes table): Set its Release_Threshold.
+	* atree.ads (Nodes table): Set its Release_Threshold.
+	(Flags table): Set its Release_Threshold.
+	* alloc.ads (Nodes_Release_Threshold): New constant declaration.
+	(Orig_Nodes_Release_Threshold): New constant declaration.
+	* debug.adb (switch d.9): Left free.
+	* gnat1drv.adb (Post_Compilation_Validation_Checks): Enable
+	validation of pragmas Compile_Time_Error and Compile_Time_Warning.
+
+2016-10-13  Hristian Kirtchev  <kirtchev@adacore.com>
+
 	* sem_ch6.adb (Create_Extra_Formals): Generate
 	an Itype reference for the object extra formal in case the
 	subprogram is called within the same or nested scope.
diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads
index 4cdb1d2..7112fab 100644
--- a/gcc/ada/alloc.ads
+++ b/gcc/ada/alloc.ads
@@ -102,6 +102,7 @@ package Alloc is
 
    Nodes_Initial                    : constant := 50_000;  -- Atree
    Nodes_Increment                  : constant := 100;
+   Nodes_Release_Threshold          : constant := 100_000;
 
    Notes_Initial                    : constant := 100;     -- Lib
    Notes_Increment                  : constant := 200;
@@ -111,6 +112,7 @@ package Alloc is
 
    Orig_Nodes_Initial               : constant := 50_000;  -- Atree
    Orig_Nodes_Increment             : constant := 100;
+   Orig_Nodes_Release_Threshold     : constant := 100_000;
 
    Pending_Instantiations_Initial   : constant := 10;      -- Inline
    Pending_Instantiations_Increment : constant := 100;
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 87ef79f..44188cf 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -516,6 +516,7 @@ package body Atree is
       Table_Low_Bound      => First_Node_Id,
       Table_Initial        => Alloc.Orig_Nodes_Initial,
       Table_Increment      => Alloc.Orig_Nodes_Increment,
+      Release_Threshold    => Alloc.Orig_Nodes_Release_Threshold,
       Table_Name           => "Orig_Nodes");
 
    --------------------------
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index 2d911b2..bf4e52e 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -4206,6 +4206,7 @@ package Atree is
         Table_Low_Bound      => First_Node_Id,
         Table_Initial        => Alloc.Nodes_Initial,
         Table_Increment      => Alloc.Nodes_Increment,
+        Release_Threshold    => Alloc.Nodes_Release_Threshold,
         Table_Name           => "Nodes");
 
       --  The following is a parallel table to Nodes, which provides 8 more
@@ -4251,6 +4252,7 @@ package Atree is
         Table_Low_Bound      => First_Node_Id,
         Table_Initial        => Alloc.Nodes_Initial,
         Table_Increment      => Alloc.Nodes_Increment,
+        Release_Threshold    => Alloc.Nodes_Release_Threshold,
         Table_Name           => "Flags");
 
    end Atree_Private_Part;
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index d936737..e3c53dd 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -163,7 +163,7 @@ package body Debug is
    --  d.6
    --  d.7
    --  d.8
-   --  d.9  Enable validation of pragma Compile_Time_[Error/Warning]
+   --  d.9
 
    --  Debug flags for binder (GNATBIND)
 
@@ -774,10 +774,6 @@ package body Debug is
    --  d.5  By default a subprogram imported generates a subprogram profile.
    --       This debug flag disables this generation when generating C code,
    --       assuming a proper #include will be used instead.
-   --
-   --  d.9  Flag used temporarily to enable the validation of pragmas Compile_
-   --       Time_Error and Compile_Time_Warning after the back end has been
-   --       called.
 
    ------------------------------------------
    -- Documentation for Binder Debug Flags --
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 7109dcd..dd812cc 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -7176,6 +7176,13 @@ package body Exp_Ch9 is
    --  Start of processing for Expand_N_Asynchronous_Select
 
    begin
+      --  Asynchronous select is not supported on restricted runtimes. Don't
+      --  try to expand.
+
+      if Restricted_Profile then
+         return;
+      end if;
+
       Process_Statements_For_Controlled_Objects (Trig);
       Process_Statements_For_Controlled_Objects (Abrt);
 
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index 605bac5..929bfcc 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -875,18 +875,13 @@ procedure Gnat1drv is
       --  and alignment annotated by the backend where possible). We need to
       --  unlock temporarily these tables to reanalyze their expression.
 
-      --  ??? temporarily disabled since it causes regressions with large
-      --  sources
-
-      if Debug_Flag_Dot_9 then
-         Atree.Unlock;
-         Nlists.Unlock;
-         Sem.Unlock;
-         Sem_Ch13.Validate_Compile_Time_Warning_Errors;
-         Sem.Lock;
-         Nlists.Lock;
-         Atree.Lock;
-      end if;
+      Atree.Unlock;
+      Nlists.Unlock;
+      Sem.Unlock;
+      Sem_Ch13.Validate_Compile_Time_Warning_Errors;
+      Sem.Lock;
+      Nlists.Lock;
+      Atree.Lock;
 
       --  Validate unchecked conversions (using the values for size and
       --  alignment annotated by the backend where possible).
diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb
index dcb5dd4..b40446a 100644
--- a/gcc/ada/nlists.adb
+++ b/gcc/ada/nlists.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2014, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2016, 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- --
@@ -90,6 +90,7 @@ package body Nlists is
       Table_Low_Bound      => First_Node_Id,
       Table_Initial        => Alloc.Orig_Nodes_Initial,
       Table_Increment      => Alloc.Orig_Nodes_Increment,
+      Release_Threshold    => Alloc.Orig_Nodes_Release_Threshold,
       Table_Name           => "Next_Node");
 
    package Prev_Node is new Table.Table (
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 814d118..53ca284 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -274,17 +274,17 @@ package body Sem_Ch6 is
       LocX : constant Source_Ptr := Sloc (Expr);
       Spec : constant Node_Id    := Specification (N);
 
-      Def_Id : Entity_Id;
+      Asp      : Node_Id;
+      Def_Id   : Entity_Id;
+      New_Body : Node_Id;
+      New_Spec : Node_Id;
+      Orig_N   : Node_Id;
+      Ret      : Node_Id;
 
       Prev : Entity_Id;
       --  If the expression is a completion, Prev is the entity whose
       --  declaration is completed. Def_Id is needed to analyze the spec.
 
-      New_Body : Node_Id;
-      New_Spec : Node_Id;
-      Ret      : Node_Id;
-      Asp      : Node_Id;
-
    begin
       --  This is one of the occasions on which we transform the tree during
       --  semantic analysis. If this is a completion, transform the expression
@@ -392,12 +392,11 @@ package body Sem_Ch6 is
          Generate_Reference (Prev, Defining_Entity (N), 'b', Force => True);
          Rewrite (N, New_Body);
 
-         --  Correct the parent pointer of the aspect specification list to
-         --  reference the rewritten node.
+         --  Remove any existing aspects from the original node because the act
+         --  of rewriting cases the list to be shared between the two nodes.
 
-         if Has_Aspects (N) then
-            Set_Parent (Aspect_Specifications (N), N);
-         end if;
+         Orig_N := Original_Node (N);
+         Remove_Aspects (Orig_N);
 
          --  Propagate any pragmas that apply to the expression function to the
          --  proper body when the expression function acts as a completion.
@@ -406,6 +405,14 @@ package body Sem_Ch6 is
          Relocate_Pragmas_To_Body (N);
          Analyze (N);
 
+         --  Once the aspects of the generated body has been analyzed, create a
+         --  copy for ASIS purposes and assciate it with the original node.
+
+         if Has_Aspects (N) then
+            Set_Aspect_Specifications (Orig_N,
+              New_Copy_List_Tree (Aspect_Specifications (N)));
+         end if;
+
          --  Prev is the previous entity with the same name, but it is can
          --  be an unrelated spec that is not completed by the expression
          --  function. In that case the relevant entity is the one in the body.
@@ -451,15 +458,21 @@ package body Sem_Ch6 is
 
          Rewrite (N, Make_Subprogram_Declaration (Loc, Specification => Spec));
 
-         --  Correct the parent pointer of the aspect specification list to
-         --  reference the rewritten node.
+         --  Remove any existing aspects from the original node because the act
+         --  of rewriting cases the list to be shared between the two nodes.
 
-         if Has_Aspects (N) then
-            Set_Parent (Aspect_Specifications (N), N);
-         end if;
+         Orig_N := Original_Node (N);
+         Remove_Aspects (Orig_N);
 
          Analyze (N);
-         Def_Id := Defining_Entity (N);
+
+         --  Once the aspects of the generated spec has been analyzed, create a
+         --  copy for ASIS purposes and assciate it with the original node.
+
+         if Has_Aspects (N) then
+            Set_Aspect_Specifications (Orig_N,
+              New_Copy_List_Tree (Aspect_Specifications (N)));
+         end if;
 
          --  If aspect SPARK_Mode was specified on the body, it needs to be
          --  repeated both on the generated spec and the body.
@@ -472,6 +485,8 @@ package body Sem_Ch6 is
             Set_Aspect_Specifications (New_Body, New_List (Asp));
          end if;
 
+         Def_Id := Defining_Entity (N);
+
          --  Within a generic pre-analyze the original expression for name
          --  capture. The body is also generated but plays no role in
          --  this because it is not part of the original source.
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index e553dab..26a4870 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -7015,8 +7015,45 @@ package body Sem_Prag is
       -------------------------------------------
 
       procedure Process_Compile_Time_Warning_Or_Error is
+         Validation_Needed : Boolean := False;
+
+         function Check_Node (N : Node_Id) return Traverse_Result;
+         --  Tree visitor that checks if N is an attribute reference that can
+         --  be statically computed by the backend. Validation_Needed is set
+         --  to True if found.
+
+         ----------------
+         -- Check_Node --
+         ----------------
+
+         function Check_Node (N : Node_Id) return Traverse_Result is
+         begin
+            if Nkind (N) = N_Attribute_Reference
+              and then Is_Entity_Name (Prefix (N))
+            then
+               declare
+                  Attr_Id : constant Attribute_Id :=
+                              Get_Attribute_Id (Attribute_Name (N));
+               begin
+                  if Attr_Id = Attribute_Alignment
+                    or else Attr_Id = Attribute_Size
+                  then
+                     Validation_Needed := True;
+                  end if;
+               end;
+            end if;
+
+            return OK;
+         end Check_Node;
+
+         procedure Check_Expression is new Traverse_Proc (Check_Node);
+
+         --  Local variables
+
          Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
 
+      --  Start of processing for Process_Compile_Time_Warning_Or_Error
+
       begin
          Check_Arg_Count (2);
          Check_No_Identifiers;
@@ -7025,8 +7062,18 @@ package body Sem_Prag is
 
          if Compile_Time_Known_Value (Arg1x) then
             Process_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
+
+         --  Register the expression for its validation after the backend has
+         --  been called if it has occurrences of attributes size or alignment
+         --  (because they may be statically computed by the backend and hence
+         --  the whole expression needs to be re-evaluated).
+
          else
-            Sem_Ch13.Validate_Compile_Time_Warning_Error (N);
+            Check_Expression (Arg1x);
+
+            if Validation_Needed then
+               Sem_Ch13.Validate_Compile_Time_Warning_Error (N);
+            end if;
          end if;
       end Process_Compile_Time_Warning_Or_Error;
 
diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb
index 34fe728..2c7eb0c 100644
--- a/gcc/ada/table.adb
+++ b/gcc/ada/table.adb
@@ -229,7 +229,6 @@ package body Table is
             Set_Standard_Output;
             raise Unrecoverable_Error;
          end if;
-
       end Reallocate;
 
       -------------
@@ -237,9 +236,36 @@ package body Table is
       -------------
 
       procedure Release is
+         Extra_Length : Int;
+         Size         : Memory.size_t;
+
       begin
          Length := Last_Val - Int (Table_Low_Bound) + 1;
-         Max    := Last_Val;
+         Size   := Memory.size_t (Length) *
+                     (Table_Type'Component_Size / Storage_Unit);
+
+         --  If the size of the table exceeds the release threshold then leave
+         --  space to store as many extra elements as 0.1% of the table length.
+
+         if Release_Threshold > 0
+           and then Size > Memory.size_t (Release_Threshold)
+         then
+            Extra_Length := Length / 1000;
+            Length := Length + Extra_Length;
+            Max    := Int (Table_Low_Bound) + Length - 1;
+
+            if Debug_Flag_D then
+               Write_Str ("--> Release_Threshold reached (length=");
+               Write_Int (Int (Size));
+               Write_Str ("): leaving room space for ");
+               Write_Int (Extra_Length);
+               Write_Str (" components");
+               Write_Eol;
+            end if;
+         else
+            Max := Last_Val;
+         end if;
+
          Reallocate;
       end Release;
 
diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads
index 4788016..e928ef0 100644
--- a/gcc/ada/table.ads
+++ b/gcc/ada/table.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2016, 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- --
@@ -47,10 +47,11 @@ package Table is
       type Table_Component_Type is private;
       type Table_Index_Type     is range <>;
 
-      Table_Low_Bound  : Table_Index_Type;
-      Table_Initial    : Pos;
-      Table_Increment  : Nat;
-      Table_Name       : String;
+      Table_Low_Bound   : Table_Index_Type;
+      Table_Initial     : Pos;
+      Table_Increment   : Nat;
+      Table_Name        : String;
+      Release_Threshold : Nat := 0;
 
    package Table is
 
@@ -151,9 +152,15 @@ package Table is
 
       procedure Release;
       --  Storage is allocated in chunks according to the values given in the
-      --  Initial and Increment parameters. A call to Release releases all
-      --  storage that is allocated, but is not logically part of the current
-      --  array value. Current array values are not affected by this call.
+      --  Initial and Increment parameters. If Release_Threshold is 0 or the
+      --  length of the table does not exceed this threshold then a call to
+      --  Release releases all storage that is allocated, but is not logically
+      --  part of the current array value; otherwise the call to Release leaves
+      --  the current array value plus 0.1% of the current table length free
+      --  elements located at the end of the table (this parameter facilitates
+      --  reopening large tables and adding a few elements without allocating a
+      --  chunk of memory). In both cases current array values are not affected
+      --  by this call.
 
       procedure Free;
       --  Free all allocated memory for the table. A call to init is required