gnat_and_program_execution.rst: Update section "Dynamic Stack Usage Analysis" to include more details about...

gcc/ada/

2017-12-15  Patrick Bernardi  <bernardi@adacore.com>

	* doc/gnat_ugn/gnat_and_program_execution.rst: Update section "Dynamic
	Stack Usage Analysis" to include more details about GNAT_STACK_LIMIT.

2017-12-15  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_util.adb (Add_Own_DIC): Ensure that the expression of the pragma
	is available (Is_Verifiable_DIC_Pragma): Moved from Sem_Util.
	* sem_util.adb (Has_Full_Default_Initialization):
	Has_Fully_Default_Initializing_DIC_Pragma is now used to determine
	whether a type has full default initialization due to pragma
	Default_Initial_Condition.
	(Has_Fully_Default_Initializing_DIC_Pragma): New routine.
	(Is_Verifiable_DIC_Pragma): Moved to Exp_Util.
	* sem_util.ads (Has_Fully_Default_Initializing_DIC_Pragma): New
	routine.
	(Is_Verifiable_DIC_Pragma): Moved to Exp_Util.
	* sem_warn.adb (Is_OK_Fully_Initialized):
	Has_Fully_Default_Initializing_DIC_Pragma is now used to determine
	whether a type has full default initialization due to pragma
	Default_Initial_Condition.

2017-12-15  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.adb (Match_Constituent): Do not quietly accept constants as
	suitable constituents.
	* exp_util.adb: Minor reformatting.

2017-12-15  Ed Schonberg  <schonberg@adacore.com>

	* exp_aggr.adb (In_Place_Assign_OK): Extend the predicate to recognize
	an array aggregate in an allocator, when the designated type is
	unconstrained and the upper bound of the aggregate belongs to the base
	type of the index.

2017-12-15  Bob Duff  <duff@adacore.com>

	* exp_ch6.adb (Expand_N_Extended_Return_Statement,
	Expand_Simple_Function_Return): Assert that the b-i-p-ness of the
	caller and callee match.  Otherwise, we would need some substantial
	changes to allow b-i-p calls non-b-i-p, and vice versa.

gcc/testsuite/

2017-12-15  Hristian Kirtchev  <kirtchev@adacore.com>

	* gnat.dg/dflt_init_cond.adb, gnat.dg/dflt_init_cond_pkg.ads: New
	testcase.

From-SVN: r255685

12 files changed, 211 insertions, 68 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5dcc378..c86b361 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,46 @@
+2017-12-15  Patrick Bernardi  <bernardi@adacore.com>
+
+	* doc/gnat_ugn/gnat_and_program_execution.rst: Update section "Dynamic
+	Stack Usage Analysis" to include more details about GNAT_STACK_LIMIT.
+
+2017-12-15  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_util.adb (Add_Own_DIC): Ensure that the expression of the pragma
+	is available (Is_Verifiable_DIC_Pragma): Moved from Sem_Util.
+	* sem_util.adb (Has_Full_Default_Initialization):
+	Has_Fully_Default_Initializing_DIC_Pragma is now used to determine
+	whether a type has full default initialization due to pragma
+	Default_Initial_Condition.
+	(Has_Fully_Default_Initializing_DIC_Pragma): New routine.
+	(Is_Verifiable_DIC_Pragma): Moved to Exp_Util.
+	* sem_util.ads (Has_Fully_Default_Initializing_DIC_Pragma): New
+	routine.
+	(Is_Verifiable_DIC_Pragma): Moved to Exp_Util.
+	* sem_warn.adb (Is_OK_Fully_Initialized):
+	Has_Fully_Default_Initializing_DIC_Pragma is now used to determine
+	whether a type has full default initialization due to pragma
+	Default_Initial_Condition.
+
+2017-12-15  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* sem_prag.adb (Match_Constituent): Do not quietly accept constants as
+	suitable constituents.
+	* exp_util.adb: Minor reformatting.
+
+2017-12-15  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_aggr.adb (In_Place_Assign_OK): Extend the predicate to recognize
+	an array aggregate in an allocator, when the designated type is
+	unconstrained and the upper bound of the aggregate belongs to the base
+	type of the index.
+
+2017-12-15  Bob Duff  <duff@adacore.com>
+
+	* exp_ch6.adb (Expand_N_Extended_Return_Statement,
+	Expand_Simple_Function_Return): Assert that the b-i-p-ness of the
+	caller and callee match.  Otherwise, we would need some substantial
+	changes to allow b-i-p calls non-b-i-p, and vice versa.
+
 2017-12-15  Ed Schonberg  <schonberg@adacore.com>
 
 	* exp_unst.adb (Unnest_Subprograms): Nothing to do if the main unit is
diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
index e350cb9..6ce22f4 100644
--- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
+++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
@@ -3817,11 +3817,20 @@ where:
   is not entirely analyzed, and it's not possible to know exactly how
   much has actually been used.
 
-The environment task stack, e.g., the stack that contains the main unit, is
-only processed when the environment variable GNAT_STACK_LIMIT is set.
+By default the environment task stack, the stack that contains the main unit,
+is not processed. To enable processing of the environment task stack, the
+environment variable GNAT_STACK_LIMIT needs to be set to the maximum size of
+the environment task stack. This amount is given in kilobytes. For example:
+
+  ::
+
+     $ set GNAT_STACK_LIMIT 1600
+
+would specify to the analyzer that the environment task stack has a limit
+of 1.6 megabytes. Any stack usage beyond this will be ignored by the analysis.
 
 The package ``GNAT.Task_Stack_Usage`` provides facilities to get
-stack usage reports at run-time. See its body for the details.
+stack-usage reports at run time. See its body for the details.
 
 
 
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 581e31c..e2313f2 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -5537,13 +5537,29 @@ package body Exp_Aggr is
                Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
 
                if not Compile_Time_Known_Value (Aggr_Lo)
-                 or else not Compile_Time_Known_Value (Aggr_Hi)
                  or else not Compile_Time_Known_Value (Obj_Lo)
                  or else not Compile_Time_Known_Value (Obj_Hi)
                  or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
-                 or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
                then
                   return False;
+
+               --  For an assignment statement we require static matching
+               --  of bounds. Ditto for an allocator whose qualified
+               --  expression is a constrained type. If the expression in
+               --  the allocator is an unconstrained array, we accept an
+               --  upper bound that is not static, to allow for non-static
+               --  expressions of the base type. Clearly there are further
+               --  possibilities (with diminishing returns) for safely
+               --  building arrays in place here.
+
+               elsif Nkind (Parent (N)) = N_Assignment_Statement
+                 or else Is_Constrained (Etype (Parent (N)))
+               then
+                  if not Compile_Time_Known_Value (Aggr_Hi)
+                   or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
+                  then
+                     return False;
+                  end if;
                end if;
 
                Next_Index (Aggr_In);
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index add30b6..f207b5b 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -4751,6 +4751,17 @@ package body Exp_Ch6 is
 
       if Nkind (Ret_Obj_Decl) = N_Object_Declaration then
          Exp := Expression (Ret_Obj_Decl);
+
+         --  Assert that if F says "return R : T := G(...) do..."
+         --  then F and G are both b-i-p, or neither b-i-p.
+
+         if Nkind (Exp) = N_Function_Call then
+            pragma Assert (Ekind (Current_Scope) = E_Function);
+            pragma Assert
+              (Is_Build_In_Place_Function (Current_Scope) =
+               Is_Build_In_Place_Function_Call (Exp));
+            null;
+         end if;
       else
          Exp := Empty;
       end if;
@@ -6446,6 +6457,17 @@ package body Exp_Ch6 is
          end if;
       end if;
 
+      --  Assert that if F says "return G(...);"
+      --  then F and G are both b-i-p, or neither b-i-p.
+
+      if Nkind (Exp) = N_Function_Call then
+         pragma Assert (Ekind (Scope_Id) = E_Function);
+         pragma Assert
+           (Is_Build_In_Place_Function (Scope_Id) =
+            Is_Build_In_Place_Function_Call (Exp));
+         null;
+      end if;
+
       --  For the case of a simple return that does not come from an
       --  extended return, in the case of build-in-place, we rewrite
       --  "return <expression>;" to be:
@@ -7095,8 +7117,6 @@ package body Exp_Ch6 is
                         return Empty;
                      end Associated_Expr;
 
-                  --  Start of processing for Expand_Simple_Function_Return
-
                   begin
                      if not Positionals_Exhausted then
                         Disc_Exp := First (Expressions (Discrim_Source));
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 959d32b..a4797c7 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -165,6 +165,10 @@ package body Exp_Util is
    --  Force evaluation of bounds of a slice, which may be given by a range
    --  or by a subtype indication with or without a constraint.
 
+   function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean;
+   --  Determine whether pragma Default_Initial_Condition denoted by Prag has
+   --  an assertion expression that should be verified at run time.
+
    function Make_CW_Equivalent_Type
      (T : Entity_Id;
       E : Node_Id) return Entity_Id;
@@ -1500,6 +1504,7 @@ package body Exp_Util is
       --  Start of processing for Add_Own_DIC
 
       begin
+         pragma Assert (Present (DIC_Expr));
          Expr := New_Copy_Tree (DIC_Expr);
 
          --  Perform the following substitution:
@@ -1733,8 +1738,6 @@ package body Exp_Util is
          --  Produce an empty completing body in the following cases:
          --    * Assertions are disabled
          --    * The DIC Assertion_Policy is Ignore
-         --    * Pragma DIC appears without an argument
-         --    * Pragma DIC appears with argument "null"
 
          if No (Stmts) then
             Stmts := New_List (Make_Null_Statement (Loc));
@@ -8715,6 +8718,21 @@ package body Exp_Util is
           and then Is_Itype (Full_Typ);
    end Is_Untagged_Private_Derivation;
 
+   ------------------------------
+   -- Is_Verifiable_DIC_Pragma --
+   ------------------------------
+
+   function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is
+      Args : constant List_Id := Pragma_Argument_Associations (Prag);
+
+   begin
+      --  To qualify as verifiable, a DIC pragma must have a non-null argument
+
+      return
+        Present (Args)
+          and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null;
+   end Is_Verifiable_DIC_Pragma;
+
    ---------------------------
    -- Is_Volatile_Reference --
    ---------------------------
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 86602ad..16113e1 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -27327,25 +27327,14 @@ package body Sem_Prag is
                      end loop;
                   end if;
 
-                  --  Constants are part of the hidden state of a package, but
-                  --  the compiler cannot determine whether they have variable
-                  --  input (SPARK RM 7.1.1(2)) and cannot classify them as a
-                  --  hidden state. Accept the constant quietly even if it is
-                  --  a visible state or lacks a Part_Of indicator.
+                  --  At this point it is known that the constituent is not
+                  --  part of the package hidden state and cannot be used in
+                  --  a refinement (SPARK RM 7.2.2(9)).
 
-                  if Ekind (Constit_Id) = E_Constant then
-                     Collect_Constituent;
-
-                  --  If we get here, then the constituent is not a hidden
-                  --  state of the related package and may not be used in a
-                  --  refinement (SPARK RM 7.2.2(9)).
-
-                  else
-                     Error_Msg_Name_1 := Chars (Spec_Id);
-                     SPARK_Msg_NE
-                       ("cannot use & in refinement, constituent is not a "
-                        & "hidden state of package %", Constit, Constit_Id);
-                  end if;
+                  Error_Msg_Name_1 := Chars (Spec_Id);
+                  SPARK_Msg_NE
+                    ("cannot use & in refinement, constituent is not a hidden "
+                     & "state of package %", Constit, Constit_Id);
                end if;
             end Match_Constituent;
 
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 5bdbd5b..688ad7b 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -10384,19 +10384,16 @@ package body Sem_Util is
 
    function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
       Comp : Entity_Id;
-      Prag : Node_Id;
 
    begin
-      --  A type subject to pragma Default_Initial_Condition is fully default
-      --  initialized when the pragma appears with a non-null argument. Since
-      --  any type may act as the full view of a private type, this check must
-      --  be performed prior to the specialized tests below.
+      --  A type subject to pragma Default_Initial_Condition may be fully
+      --  default initialized depending on inheritance and the argument of
+      --  the pragma. Since any type may act as the full view of a private
+      --  type, this check must be performed prior to the specialized tests
+      --  below.
 
-      if Has_DIC (Typ) then
-         Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
-         pragma Assert (Present (Prag));
-
-         return Is_Verifiable_DIC_Pragma (Prag);
+      if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then
+         return True;
       end if;
 
       --  A scalar type is fully default initialized if it is subject to aspect
@@ -10463,6 +10460,47 @@ package body Sem_Util is
       end if;
    end Has_Full_Default_Initialization;
 
+   -----------------------------------------------
+   -- Has_Fully_Default_Initializing_DIC_Pragma --
+   -----------------------------------------------
+
+   function Has_Fully_Default_Initializing_DIC_Pragma
+     (Typ : Entity_Id) return Boolean
+   is
+      Args : List_Id;
+      Prag : Node_Id;
+
+   begin
+      --  A type that inherits pragma Default_Initial_Condition from a parent
+      --  type is automatically fully default initialized.
+
+      if Has_Inherited_DIC (Typ) then
+         return True;
+
+      --  Otherwise the type is fully default initialized only when the pragma
+      --  appears without an argument, or the argument is non-null.
+
+      elsif Has_Own_DIC (Typ) then
+         Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
+         pragma Assert (Present (Prag));
+         Args := Pragma_Argument_Associations (Prag);
+
+         --  The pragma appears without an argument in which case it defaults
+         --  to True.
+
+         if No (Args) then
+            return True;
+
+         --  The pragma appears with a non-null expression
+
+         elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then
+            return True;
+         end if;
+      end if;
+
+      return False;
+   end Has_Fully_Default_Initializing_DIC_Pragma;
+
    --------------------
    -- Has_Infinities --
    --------------------
@@ -17018,21 +17056,6 @@ package body Sem_Util is
       end if;
    end Is_Variable;
 
-   ------------------------------
-   -- Is_Verifiable_DIC_Pragma --
-   ------------------------------
-
-   function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is
-      Args : constant List_Id := Pragma_Argument_Associations (Prag);
-
-   begin
-      --  To qualify as verifiable, a DIC pragma must have a non-null argument
-
-      return
-        Present (Args)
-          and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null;
-   end Is_Verifiable_DIC_Pragma;
-
    ---------------------------
    -- Is_Visibly_Controlled --
    ---------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index e94515d..f368eaa 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1238,8 +1238,14 @@ package Sem_Util is
    --      either include a default expression or have a type which defines
    --      full default initialization. In the case of type extensions, the
    --      parent type defines full default initialization.
-   --   * A task type
-   --   * A private type whose Default_Initial_Condition is non-null
+   --    * A task type
+   --    * A private type with pragma Default_Initial_Condition that provides
+   --      full default initialization.
+
+   function Has_Fully_Default_Initializing_DIC_Pragma
+     (Typ : Entity_Id) return Boolean;
+   --  Determine whether type Typ has a suitable Default_Initial_Condition
+   --  pragma which provides the full default initialization of the type.
 
    function Has_Infinities (E : Entity_Id) return Boolean;
    --  Determines if the range of the floating-point type E includes
@@ -1980,10 +1986,6 @@ package Sem_Util is
    --  default is True since this routine is commonly invoked as part of the
    --  semantic analysis and it must not be disturbed by the rewriten nodes.
 
-   function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean;
-   --  Determine whether pragma Default_Initial_Condition denoted by Prag has
-   --  an assertion expression which should be verified at runtime.
-
    function Is_Visibly_Controlled (T : Entity_Id) return Boolean;
    --  Check whether T is derived from a visibly controlled type. This is true
    --  if the root type is declared in Ada.Finalization. If T is derived
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index ff94cf8..ce55724 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -1742,21 +1742,16 @@ package body Sem_Warn is
       -----------------------------
 
       function Is_OK_Fully_Initialized return Boolean is
-         Prag : Node_Id;
-
       begin
          if Is_Access_Type (Typ) and then Is_Dereferenced (N) then
             return False;
 
-         --  A type subject to pragma Default_Initial_Condition is fully
-         --  default initialized when the pragma appears with a non-null
-         --  argument (SPARK RM 3.1 and SPARK RM 7.3.3).
-
-         elsif Has_DIC (Typ) then
-            Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
-            pragma Assert (Present (Prag));
+         --  A type subject to pragma Default_Initial_Condition may be fully
+         --  default initialized depending on inheritance and the argument of
+         --  the pragma (SPARK RM 3.1 and SPARK RM 7.3.3).
 
-            return Is_Verifiable_DIC_Pragma (Prag);
+         elsif Has_Fully_Default_Initializing_DIC_Pragma (Typ) then
+            return True;
 
          else
             return Is_Fully_Initialized_Type (Typ);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 8d6825a..e8d45ac 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 2017-12-15  Hristian Kirtchev  <kirtchev@adacore.com>
 
+	* gnat.dg/dflt_init_cond.adb, gnat.dg/dflt_init_cond_pkg.ads: New
+	testcase.
+
+2017-12-15  Hristian Kirtchev  <kirtchev@adacore.com>
+
 	* gnat.dg/expr_func_main.adb, gnat.dg/expr_func_pkg.ads,
 	gnat.dg/expr_func_pkg.adb: New testcase.
 
diff --git a/gcc/testsuite/gnat.dg/dflt_init_cond.adb b/gcc/testsuite/gnat.dg/dflt_init_cond.adb
new file mode 100644
index 0000000..1c4cd64
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/dflt_init_cond.adb
@@ -0,0 +1,12 @@
+--  { dg-do compile }
+
+with Dflt_Init_Cond_Pkg; use Dflt_Init_Cond_Pkg;
+
+procedure Dflt_Init_Cond is
+   E : Explicit;
+   I : Implicit;
+
+begin
+   Read (E);
+   Read (I);
+end Dflt_Init_Cond;
diff --git a/gcc/testsuite/gnat.dg/dflt_init_cond_pkg.ads b/gcc/testsuite/gnat.dg/dflt_init_cond_pkg.ads
new file mode 100644
index 0000000..e1955cd
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/dflt_init_cond_pkg.ads
@@ -0,0 +1,11 @@
+package Dflt_Init_Cond_Pkg is
+   type Explicit is limited private with Default_Initial_Condition => True;
+   type Implicit is limited private with Default_Initial_Condition;
+
+   procedure Read (Obj : Explicit);
+   procedure Read (Obj : Implicit);
+
+private
+   type Implicit is access all Integer;
+   type Explicit is access all Integer;
+end Dflt_Init_Cond_Pkg;