2015-10-20 Hristian Kirtchev <kirtchev@adacore.com>

	* exp_ch7.adb (Process_Declarations): A loop
	parameter does not require finalization actions.

2015-10-20  Eric Botcazou  <ebotcazou@adacore.com>

	* exp_ch6.adb (Expand_Simple_Function_Return): Do not create an
	actual subtype for a mutable record return type if the expression
	is itself a function call.

2015-10-20  Dmitriy Anisimkov  <anisimko@adacore.com>

	* s-atocou.adb, s-atocou-builtin.adb: Fix implementation description
	related to new type support.

2015-10-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb (Resolve_Explicit_Dererence): Call Analyze_Dimension
	to propagate dimension information from prefix.
	* sem_dim.adb (Analyze_Dimension): Handle Explicit_Dereference.
	* inline.ads: minor whitespace fix in comment
	* sem_ch6.adb: minor gramar fix in comment

2015-10-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch3.adb (Analyze_Object_Contract):
	A protected type or a protected object is allowed to have a
	discriminated part.

2015-10-20  Bob Duff  <duff@adacore.com>

	* sem_util.adb (Requires_Transient_Scope):
	Return true for mutable records if the maximum size is very large.

2015-10-20  Eric Botcazou  <ebotcazou@adacore.com>

	* a-except-2005.adb (To_Stderr): Import Put_Char_Stderr with
	the same signature as in System.IO.Put.



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

12 files changed, 186 insertions, 28 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index fd2f4f600df..0599e3222f9 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,43 @@
+2015-10-20  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch7.adb (Process_Declarations): A loop
+	parameter does not require finalization actions.
+
+2015-10-20  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* exp_ch6.adb (Expand_Simple_Function_Return): Do not create an
+	actual subtype for a mutable record return type if the expression
+	is itself a function call.
+
+2015-10-20  Dmitriy Anisimkov  <anisimko@adacore.com>
+
+	* s-atocou.adb, s-atocou-builtin.adb: Fix implementation description
+	related to new type support.
+
+2015-10-20  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_res.adb (Resolve_Explicit_Dererence): Call Analyze_Dimension
+	to propagate dimension information from prefix.
+	* sem_dim.adb (Analyze_Dimension): Handle Explicit_Dereference.
+	* inline.ads: minor whitespace fix in comment
+	* sem_ch6.adb: minor gramar fix in comment
+
+2015-10-20  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* sem_ch3.adb (Analyze_Object_Contract):
+	A protected type or a protected object is allowed to have a
+	discriminated part.
+
+2015-10-20  Bob Duff  <duff@adacore.com>
+
+	* sem_util.adb (Requires_Transient_Scope):
+	Return true for mutable records if the maximum size is very large.
+
+2015-10-20  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* a-except-2005.adb (To_Stderr): Import Put_Char_Stderr with
+	the same signature as in System.IO.Put.
+
 2015-10-20  Bob Duff  <duff@adacore.com>
 
 	* a-cobove.adb (Set_Length): Restore previous logic, but with "Checks
diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb
index e7929178061..43a556d4783 100644
--- a/gcc/ada/a-except-2005.adb
+++ b/gcc/ada/a-except-2005.adb
@@ -1631,11 +1631,10 @@ package body Ada.Exceptions is
    ---------------
 
    procedure To_Stderr (C : Character) is
-      type int is new Integer;
-      procedure put_char_stderr (C : int);
-      pragma Import (C, put_char_stderr, "put_char_stderr");
+      procedure Put_Char_Stderr (C : Character);
+      pragma Import (C, Put_Char_Stderr, "put_char_stderr");
    begin
-      put_char_stderr (Character'Pos (C));
+      Put_Char_Stderr (C);
    end To_Stderr;
 
    procedure To_Stderr (S : String) is
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 0a3095338af..e7d1dcec7a1 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -5942,17 +5942,21 @@ package body Exp_Ch6 is
 
       elsif not Requires_Transient_Scope (R_Type) then
 
-         --  Mutable records with no variable length components are not
-         --  returned on the sec-stack, so we need to make sure that the
-         --  backend will only copy back the size of the actual value, and not
-         --  the maximum size. We create an actual subtype for this purpose.
+         --  Mutable records with variable-length components are not returned
+         --  on the sec-stack, so we need to make sure that the back end will
+         --  only copy back the size of the actual value, and not the maximum
+         --  size. We create an actual subtype for this purpose. However we
+         --  need not do it if the expression is a function call since this
+         --  will be done in the called function and doing it here too would
+         --  cause a temporary with maximum size to be created.
 
          declare
             Ubt  : constant Entity_Id := Underlying_Type (Base_Type (Exptyp));
             Decl : Node_Id;
             Ent  : Entity_Id;
          begin
-            if Has_Discriminants (Ubt)
+            if Nkind (Exp) /= N_Function_Call
+              and then Has_Discriminants (Ubt)
               and then not Is_Constrained (Ubt)
               and then not Has_Unchecked_Union (Ubt)
             then
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 3836e8575ea..5a241b2af36 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -1837,6 +1837,15 @@ package body Exp_Ch7 is
                elsif Is_Ignored_Ghost_Entity (Obj_Id) then
                   null;
 
+               --  The expansion of iterator loops generates an object
+               --  declaration where the Ekind is explicitly set to loop
+               --  parameter. This is to ensure that the loop parameter behaves
+               --  as a constant from user code point of view. Such object are
+               --  never controlled and do not require finalization.
+
+               elsif Ekind (Obj_Id) = E_Loop_Parameter then
+                  null;
+
                --  The object is of the form:
                --    Obj : Typ [:= Expr];
 
diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads
index 5d1c5bb7278..223c3dc174a 100644
--- a/gcc/ada/inline.ads
+++ b/gcc/ada/inline.ads
@@ -165,7 +165,7 @@ package Inline is
    --  subsequently used for inline expansions at call sites. If subprogram can
    --  be inlined (depending on size and nature of local declarations) the
    --  template body is created. Otherwise subprogram body is treated normally
-   --  and calls are not inlined in the frontend.  If proper warnings are
+   --  and calls are not inlined in the frontend. If proper warnings are
    --  enabled and the subprogram contains a construct that cannot be inlined,
    --  the problematic construct is flagged accordingly.
 
diff --git a/gcc/ada/s-atocou-builtin.adb b/gcc/ada/s-atocou-builtin.adb
index 1df1c07b258..36a939fd89e 100644
--- a/gcc/ada/s-atocou-builtin.adb
+++ b/gcc/ada/s-atocou-builtin.adb
@@ -29,8 +29,9 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
---  This package implements Atomic_Counter operatiobns for platforms where
---  GCC supports __sync_add_and_fetch_4 and __sync_sub_and_fetch_4 builtins.
+--  This package implements Atomic_Counter and Atomic_Unsigned operations
+--  for platforms where GCC supports __sync_add_and_fetch_4 and
+--  __sync_sub_and_fetch_4 builtins.
 
 package body System.Atomic_Counters is
 
diff --git a/gcc/ada/s-atocou.adb b/gcc/ada/s-atocou.adb
index 87e7818b820..2897c6c8368 100644
--- a/gcc/ada/s-atocou.adb
+++ b/gcc/ada/s-atocou.adb
@@ -29,12 +29,9 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
---  This is dummy version of the package, for use on platforms where this
---  capability is not supported. Any use of any of the routines in this
---  package will raise Program_Error.
-
---  Why don't we use pragma Unimplemented_Unit in a dummy spec, this would
---  seem much more useful than raising an exception at run time ???
+--  This is version of the package, for use on platforms where this capability
+--  is not supported. All Atomic_Counter operations raises Program_Error,
+--  Atomic_Unsigned operations processed in non-atomic manner.
 
 package body System.Atomic_Counters is
 
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 555c361b1d3..d91f831ec33 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3347,9 +3347,11 @@ package body Sem_Ch3 is
                      Obj_Id);
 
                --  An object of a discriminated type cannot be effectively
-               --  volatile (SPARK RM C.6(4)).
+               --  volatile except for protected objects (SPARK RM 7.1.3(5)).
 
-               elsif Has_Discriminants (Obj_Typ) then
+               elsif Has_Discriminants (Obj_Typ)
+                 and then not Is_Protected_Type (Obj_Typ)
+               then
                   Error_Msg_N
                     ("discriminated object & cannot be volatile", Obj_Id);
 
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 5e1ddf5d167..0243700eb83 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -265,15 +265,16 @@ package body Sem_Ch6 is
       LocX : constant Source_Ptr := Sloc (Expr);
       Spec : constant Node_Id    := Specification (N);
 
-      Def_Id :  Entity_Id;
+      Def_Id : Entity_Id;
 
-      Prev :  Entity_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
@@ -449,6 +450,17 @@ package body Sem_Ch6 is
 
          Analyze (N);
 
+         --  If aspect SPARK_Mode was specified on the body, it needs to be
+         --  repeated both on the generated spec and the body.
+
+         Asp := Find_Aspect (Defining_Unit_Name (Spec), Aspect_SPARK_Mode);
+
+         if Present (Asp) then
+            Asp := New_Copy_Tree (Asp);
+            Set_Analyzed (Asp, False);
+            Set_Aspect_Specifications (New_Body, New_List (Asp));
+         end if;
+
          --  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.
@@ -3632,8 +3644,8 @@ package body Sem_Ch6 is
       --  declaration for now, as inlining of subprogram bodies acting as
       --  declarations, or subprogram stubs, are not supported by frontend
       --  inlining. This inlining should occur after analysis of the body, so
-      --  that it is known whether the value of SPARK_Mode applicable to the
-      --  body, which can be defined by a pragma inside the body.
+      --  that it is known whether the value of SPARK_Mode, which can be
+      --  defined by a pragma inside the body, is applicable to the body.
 
       elsif GNATprove_Mode
         and then Full_Analysis
diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb
index ebacba9f965..e9bafa40f8a 100644
--- a/gcc/ada/sem_dim.adb
+++ b/gcc/ada/sem_dim.adb
@@ -194,6 +194,7 @@ package body Sem_Dim is
    OK_For_Dimension : constant array (Node_Kind) of Boolean :=
      (N_Attribute_Reference       => True,
       N_Expanded_Name             => True,
+      N_Explicit_Dereference      => True,
       N_Defining_Identifier       => True,
       N_Function_Call             => True,
       N_Identifier                => True,
@@ -1135,6 +1136,7 @@ package body Sem_Dim is
 
          when N_Attribute_Reference       |
               N_Expanded_Name             |
+              N_Explicit_Dereference      |
               N_Function_Call             |
               N_Identifier                |
               N_Indexed_Component         |
@@ -2093,7 +2095,6 @@ package body Sem_Dim is
 
    procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is
       Expr                : constant Node_Id := Expression (N);
-      Dims_Of_Expr        : constant Dimension_Type := Dimensions_Of (Expr);
       Return_Ent          : constant Entity_Id := Return_Statement_Entity (N);
       Return_Etyp         : constant Entity_Id :=
                               Etype (Return_Applies_To (Return_Ent));
@@ -2126,7 +2127,7 @@ package body Sem_Dim is
    --  Start of processing for Analyze_Dimension_Simple_Return_Statement
 
    begin
-      if Dims_Of_Return_Etyp /= Dims_Of_Expr then
+      if Dims_Of_Return_Etyp /= Dimensions_Of (Expr) then
          Error_Dim_Msg_For_Simple_Return_Statement (N, Return_Etyp, Expr);
          Remove_Dimensions (Expr);
       end if;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 5b62aed1ad9..9d7e6da6077 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -8067,6 +8067,7 @@ package body Sem_Res is
          Set_Etype (N, Get_Actual_Subtype (N));
       end if;
 
+      Analyze_Dimension (N);
       --  Note: No Eval processing is required for an explicit dereference,
       --  because such a name can never be static.
 
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 6875f3aeb96..0c6e2b00b61 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -17215,6 +17215,11 @@ package body Sem_Util is
       --  could be nested inside some other record that is constrained by
       --  nondiscriminants). That is, the recursive calls are too conservative.
 
+      function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean;
+      --  Returns True if Typ is a nonlimited record with defaulted
+      --  discriminants whose max size makes it unsuitable for allocating on
+      --  the primary stack.
+
       ------------------------------
       -- Caller_Known_Size_Record --
       ------------------------------
@@ -17267,6 +17272,85 @@ package body Sem_Util is
          return True;
       end Caller_Known_Size_Record;
 
+      ------------------------------
+      -- Large_Max_Size_Mutable --
+      ------------------------------
+
+      function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is
+         pragma Assert (Typ = Underlying_Type (Typ));
+
+         function Is_Large_Discrete_Type (T : Entity_Id) return Boolean;
+         --  Returns true if the discrete type T has a large range
+
+         ----------------------------
+         -- Is_Large_Discrete_Type --
+         ----------------------------
+
+         function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is
+            Threshold : constant Int := 16;
+            --  Arbitrary threshold above which we consider it "large". We want
+            --  a fairly large threshold, because these large types really
+            --  shouldn't have default discriminants in the first place, in
+            --  most cases.
+
+         begin
+            return UI_To_Int (RM_Size (T)) > Threshold;
+         end Is_Large_Discrete_Type;
+
+      begin
+         if Is_Record_Type (Typ)
+           and then not Is_Limited_View (Typ)
+           and then Has_Defaulted_Discriminants (Typ)
+         then
+            --  Loop through the components, looking for an array whose upper
+            --  bound(s) depends on discriminants, where both the subtype of
+            --  the discriminant and the index subtype are too large.
+
+            declare
+               Comp : Entity_Id;
+
+            begin
+               Comp := First_Entity (Typ);
+               while Present (Comp) loop
+                  if Ekind (Comp) = E_Component then
+                     declare
+                        Comp_Type : constant Entity_Id :=
+                                      Underlying_Type (Etype (Comp));
+                        Indx : Node_Id;
+                        Ityp : Entity_Id;
+                        Hi   : Node_Id;
+
+                     begin
+                        if Is_Array_Type (Comp_Type) then
+                           Indx := First_Index (Comp_Type);
+
+                           while Present (Indx) loop
+                              Ityp := Etype (Indx);
+                              Hi := Type_High_Bound (Ityp);
+
+                              if Nkind (Hi) = N_Identifier
+                                and then Ekind (Entity (Hi)) = E_Discriminant
+                                and then Is_Large_Discrete_Type (Ityp)
+                                and then Is_Large_Discrete_Type
+                                           (Etype (Entity (Hi)))
+                              then
+                                 return True;
+                              end if;
+
+                              Next_Index (Indx);
+                           end loop;
+                        end if;
+                     end;
+                  end if;
+
+                  Next_Entity (Comp);
+               end loop;
+            end;
+         end if;
+
+         return False;
+      end Large_Max_Size_Mutable;
+
       --  Local declarations
 
       Typ : constant Entity_Id := Underlying_Type (Id);
@@ -17313,10 +17397,18 @@ package body Sem_Util is
 
       --  Untagged definite subtypes are known size. This includes all
       --  elementary [sub]types. Tasks are known size even if they have
-      --  discriminants.
+      --  discriminants. So we return False here, with one exception:
+      --  For a type like:
+      --    type T (Last : Natural := 0) is
+      --       X : String (1 .. Last);
+      --    end record;
+      --  we return True. That's because for "P(F(...));", where F returns T,
+      --  we don't know the size of the result at the call site, so if we
+      --  allocated it on the primary stack, we would have to allocate the
+      --  maximum size, which is way too big.
 
       elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
-         return False;
+         return Large_Max_Size_Mutable (Typ);
 
       --  Indefinite (discriminated) untagged record or protected type