2014-07-17 Vincent Celier <celier@adacore.com>

	* gnatbind.adb: Change in message "try ... for more information".

2014-07-17  Robert Dewar  <dewar@adacore.com>

	* sprint.adb: Code clean up.

2014-07-17  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Find_Last_Init): Relocate local variables to
	the relevant code section. Add new local constant Obj_Id. When
	a limited controlled object is initialized by a function call,
	the build-in-place object access function call acts as the last
	initialization statement.
	* exp_util.adb (Is_Object_Access_BIP_Func_Call): New routine.
	(Is_Secondary_Stack_BIP_Func_Call): Code reformatting.
	* exp_util.ads (Is_Object_Access_BIP_Func_Call): New routine.

2014-07-17  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Analyze_Generic_Renaming): For generic subprograms,
	propagate intrinsic flag to renamed entity, to allow e.g. renaming
	of Unchecked_Conversion.
	* sem_ch3.adb (Analyze_Declarations): Do not analyze contracts
	if the declaration has errors.

2014-07-17  Ed Schonberg  <schonberg@adacore.com>

	* a-rbtgbk.adb: a-rbtgbk.adb (Generic_Insert_Post): Check whether
	container is busy before checking whether capacity allows for
	a further insertion. Insertion in a busy container that is full
	raises Program_Error rather than Capacity_Error. Previous to that
	patch which exception was raised varied among container types.



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

9 files changed, 281 insertions, 96 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index fd13214279d..c2351f9bf2f 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,38 @@
+2014-07-17  Vincent Celier  <celier@adacore.com>
+
+	* gnatbind.adb: Change in message "try ... for more information".
+
+2014-07-17  Robert Dewar  <dewar@adacore.com>
+
+	* sprint.adb: Code clean up.
+
+2014-07-17  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch7.adb (Find_Last_Init): Relocate local variables to
+	the relevant code section. Add new local constant Obj_Id. When
+	a limited controlled object is initialized by a function call,
+	the build-in-place object access function call acts as the last
+	initialization statement.
+	* exp_util.adb (Is_Object_Access_BIP_Func_Call): New routine.
+	(Is_Secondary_Stack_BIP_Func_Call): Code reformatting.
+	* exp_util.ads (Is_Object_Access_BIP_Func_Call): New routine.
+
+2014-07-17  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch8.adb (Analyze_Generic_Renaming): For generic subprograms,
+	propagate intrinsic flag to renamed entity, to allow e.g. renaming
+	of Unchecked_Conversion.
+	* sem_ch3.adb (Analyze_Declarations): Do not analyze contracts
+	if the declaration has errors.
+
+2014-07-17  Ed Schonberg  <schonberg@adacore.com>
+
+	* a-rbtgbk.adb: a-rbtgbk.adb (Generic_Insert_Post): Check whether
+	container is busy before checking whether capacity allows for
+	a further insertion. Insertion in a busy container that is full
+	raises Program_Error rather than Capacity_Error. Previous to that
+	patch which exception was raised varied among container types.
+
 2014-07-17  Robert Dewar  <dewar@adacore.com>
 
 	* g-comlin.ads, g-comlin.adb: Minor clean up.
diff --git a/gcc/ada/a-rbtgbk.adb b/gcc/ada/a-rbtgbk.adb
index e270abf1402..dba3e0bd095 100644
--- a/gcc/ada/a-rbtgbk.adb
+++ b/gcc/ada/a-rbtgbk.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2014, 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- --
@@ -349,15 +349,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is
       N : Nodes_Type renames Tree.Nodes;
 
    begin
-      if Tree.Length >= Tree.Capacity then
-         raise Capacity_Error with "not enough capacity to insert new item";
-      end if;
-
       if Tree.Busy > 0 then
          raise Program_Error with
            "attempt to tamper with cursors (container is busy)";
       end if;
 
+      if Tree.Length >= Tree.Capacity then
+         raise Capacity_Error with "not enough capacity to insert new item";
+      end if;
+
       Z := New_Node;
       pragma Assert (Z /= 0);
 
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index f48f1149b0e..2f6ae985249 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -2256,10 +2256,6 @@ package body Exp_Ch7 is
             Last_Init   : out Node_Id;
             Body_Insert : out Node_Id)
          is
-            Nod_1 : Node_Id := Empty;
-            Nod_2 : Node_Id := Empty;
-            Utyp  : Entity_Id;
-
             function Is_Init_Call
               (N   : Node_Id;
                Typ : Entity_Id) return Boolean;
@@ -2332,6 +2328,14 @@ package body Exp_Ch7 is
                return Result;
             end Next_Suitable_Statement;
 
+            --  Local variables
+
+            Obj_Id : constant Entity_Id := Defining_Entity (Decl);
+            Nod_1  : Node_Id := Empty;
+            Nod_2  : Node_Id := Empty;
+            Stmt   : Node_Id;
+            Utyp   : Entity_Id;
+
          --  Start of processing for Find_Last_Init
 
          begin
@@ -2357,6 +2361,42 @@ package body Exp_Ch7 is
                Utyp := Full_View (Utyp);
             end if;
 
+            --  A limited controlled object initialized by a function call uses
+            --  the build-in-place machinery to obtain its value.
+
+            --    Obj : Lim_Controlled_Type := Func_Call;
+
+            --  is expanded into
+
+            --    Obj  : Lim_Controlled_Type;
+            --    type Ptr_Typ is access Lim_Controlled_Type;
+            --    Temp : constant Ptr_Typ :=
+            --             Func_Call
+            --               (BIPalloc  => 1,
+            --                BIPaccess => Obj'Unrestricted_Access)'reference;
+
+            --  In this scenario the declaration of the temporary acts as the
+            --  last initialization statement.
+
+            if Is_Limited_Type (Utyp)
+              and then Has_Init_Expression (Decl)
+              and then No (Expression (Decl))
+            then
+               Stmt := Next (Decl);
+               while Present (Stmt) loop
+                  if Nkind (Stmt) = N_Object_Declaration
+                    and then Present (Expression (Stmt))
+                    and then Is_Object_Access_BIP_Func_Call
+                               (Expr   => Expression (Stmt),
+                                Obj_Id => Obj_Id)
+                  then
+                     Last_Init := Stmt;
+                     exit;
+                  end if;
+
+                  Next (Stmt);
+               end loop;
+
             --  The init procedures are arranged as follows:
 
             --    Object : Controlled_Type;
@@ -2366,53 +2406,55 @@ package body Exp_Ch7 is
             --  where the user-defined initialize may be optional or may appear
             --  inside a block when abort deferral is needed.
 
-            Nod_1 := Next_Suitable_Statement (Decl);
-            if Present (Nod_1) then
-               Nod_2 := Next_Suitable_Statement (Nod_1);
+            else
+               Nod_1 := Next_Suitable_Statement (Decl);
 
-               --  The statement following an object declaration is always a
-               --  call to the type init proc.
+               if Present (Nod_1) then
+                  Nod_2 := Next_Suitable_Statement (Nod_1);
 
-               Last_Init := Nod_1;
-            end if;
+                  --  The statement following an object declaration is always a
+                  --  call to the type init proc.
 
-            --  Optional user-defined init or deep init processing
+                  Last_Init := Nod_1;
+               end if;
 
-            if Present (Nod_2) then
+               --  Optional user-defined init or deep init processing
 
-               --  The statement following the type init proc may be a block
-               --  statement in cases where abort deferral is required.
+               if Present (Nod_2) then
 
-               if Nkind (Nod_2) = N_Block_Statement then
-                  declare
-                     HSS  : constant Node_Id :=
-                              Handled_Statement_Sequence (Nod_2);
-                     Stmt : Node_Id;
+                  --  The statement following the type init proc may be a block
+                  --  statement in cases where abort deferral is required.
 
-                  begin
-                     if Present (HSS)
-                       and then Present (Statements (HSS))
-                     then
-                        Stmt := First (Statements (HSS));
+                  if Nkind (Nod_2) = N_Block_Statement then
+                     declare
+                        HSS  : constant Node_Id :=
+                                 Handled_Statement_Sequence (Nod_2);
+                        Stmt : Node_Id;
 
-                        --  Examine individual block statements and locate the
-                        --  call to [Deep_]Initialze.
+                     begin
+                        if Present (HSS)
+                          and then Present (Statements (HSS))
+                        then
+                           --  Examine individual block statements and locate
+                           --  the call to [Deep_]Initialze.
 
-                        while Present (Stmt) loop
-                           if Is_Init_Call (Stmt, Utyp) then
-                              Last_Init   := Stmt;
-                              Body_Insert := Nod_2;
+                           Stmt := First (Statements (HSS));
+                           while Present (Stmt) loop
+                              if Is_Init_Call (Stmt, Utyp) then
+                                 Last_Init   := Stmt;
+                                 Body_Insert := Nod_2;
 
-                              exit;
-                           end if;
+                                 exit;
+                              end if;
 
-                           Next (Stmt);
-                        end loop;
-                     end if;
-                  end;
+                              Next (Stmt);
+                           end loop;
+                        end if;
+                     end;
 
-               elsif Is_Init_Call (Nod_2, Utyp) then
-                  Last_Init := Nod_2;
+                  elsif Is_Init_Call (Nod_2, Utyp) then
+                     Last_Init := Nod_2;
+                  end if;
                end if;
             end if;
          end Find_Last_Init;
@@ -2434,7 +2476,7 @@ package body Exp_Ch7 is
 
          --  Set a new value for the state counter and insert the statement
          --  after the object declaration. Generate:
-         --
+
          --    Counter := <value>;
 
          Inc_Decl :=
@@ -2496,7 +2538,7 @@ package body Exp_Ch7 is
              Label_Construct     => Label));
 
          --  Create the associated jump with this object, generate:
-         --
+
          --    when <counter> =>
          --       goto L<counter>;
 
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index acd10734d8b..800c276d536 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -4794,6 +4794,79 @@ package body Exp_Util is
           and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
    end Is_Non_BIP_Func_Call;
 
+   ------------------------------------
+   -- Is_Object_Access_BIP_Func_Call --
+   ------------------------------------
+
+   function Is_Object_Access_BIP_Func_Call
+      (Expr   : Node_Id;
+       Obj_Id : Entity_Id) return Boolean
+   is
+      Access_Nam : Name_Id := No_Name;
+      Actual     : Node_Id;
+      Call       : Node_Id;
+      Formal     : Node_Id;
+      Param      : Node_Id;
+
+   begin
+      --  Build-in-place calls usually appear in 'reference format. Note that
+      --  the accessibility check machinery may add an extra 'reference due to
+      --  side effect removal.
+
+      Call := Expr;
+      while Nkind (Call) = N_Reference loop
+         Call := Prefix (Call);
+      end loop;
+
+      if Nkind_In (Call, N_Qualified_Expression,
+                         N_Unchecked_Type_Conversion)
+      then
+         Call := Expression (Call);
+      end if;
+
+      if Is_Build_In_Place_Function_Call (Call) then
+
+         --  Examine all parameter associations of the function call
+
+         Param := First (Parameter_Associations (Call));
+         while Present (Param) loop
+            if Nkind (Param) = N_Parameter_Association
+              and then Nkind (Selector_Name (Param)) = N_Identifier
+            then
+               Formal := Selector_Name (Param);
+               Actual := Explicit_Actual_Parameter (Param);
+
+               --  Construct the name of formal BIPaccess. It is much easier to
+               --  extract the name of the function using an arbitrary formal's
+               --  scope rather than the Name field of Call.
+
+               if Access_Nam = No_Name and then Present (Entity (Formal)) then
+                  Access_Nam :=
+                    New_External_Name
+                      (Chars (Scope (Entity (Formal))),
+                       BIP_Formal_Suffix (BIP_Object_Access));
+               end if;
+
+               --  A match for BIPaccess => Obj_Id'Unrestricted_Access has been
+               --  found.
+
+               if Chars (Formal) = Access_Nam
+                 and then Nkind (Actual) = N_Attribute_Reference
+                 and then Attribute_Name (Actual) = Name_Unrestricted_Access
+                 and then Nkind (Prefix (Actual)) = N_Identifier
+                 and then Entity (Prefix (Actual)) = Obj_Id
+               then
+                  return True;
+               end if;
+            end if;
+
+            Next (Param);
+         end loop;
+      end if;
+
+      return False;
+   end Is_Object_Access_BIP_Func_Call;
+
    ----------------------------------
    -- Is_Possibly_Unaligned_Object --
    ----------------------------------
@@ -5183,7 +5256,11 @@ package body Exp_Util is
    --------------------------------------
 
    function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
-      Call : Node_Id := Expr;
+      Alloc_Nam : Name_Id := No_Name;
+      Actual    : Node_Id;
+      Call      : Node_Id := Expr;
+      Formal    : Node_Id;
+      Param     : Node_Id;
 
    begin
       --  Build-in-place calls usually appear in 'reference format. Note that
@@ -5201,49 +5278,40 @@ package body Exp_Util is
       end if;
 
       if Is_Build_In_Place_Function_Call (Call) then
-         declare
-            Access_Nam : Name_Id := No_Name;
-            Actual     : Node_Id;
-            Param      : Node_Id;
-            Formal     : Node_Id;
-
-         begin
-            --  Examine all parameter associations of the function call
-
-            Param := First (Parameter_Associations (Call));
-            while Present (Param) loop
-               if Nkind (Param) = N_Parameter_Association
-                 and then Nkind (Selector_Name (Param)) = N_Identifier
-               then
-                  Formal := Selector_Name (Param);
-                  Actual := Explicit_Actual_Parameter (Param);
 
-                  --  Construct the name of formal BIPalloc. It is much easier
-                  --  to extract the name of the function using an arbitrary
-                  --  formal's scope rather than the Name field of Call.
+         --  Examine all parameter associations of the function call
 
-                  if Access_Nam = No_Name
-                    and then Present (Entity (Formal))
-                  then
-                     Access_Nam :=
-                       New_External_Name
-                         (Chars (Scope (Entity (Formal))),
-                          BIP_Formal_Suffix (BIP_Alloc_Form));
-                  end if;
+         Param := First (Parameter_Associations (Call));
+         while Present (Param) loop
+            if Nkind (Param) = N_Parameter_Association
+              and then Nkind (Selector_Name (Param)) = N_Identifier
+            then
+               Formal := Selector_Name (Param);
+               Actual := Explicit_Actual_Parameter (Param);
+
+               --  Construct the name of formal BIPalloc. It is much easier to
+               --  extract the name of the function using an arbitrary formal's
+               --  scope rather than the Name field of Call.
+
+               if Alloc_Nam = No_Name and then Present (Entity (Formal)) then
+                  Alloc_Nam :=
+                    New_External_Name
+                      (Chars (Scope (Entity (Formal))),
+                       BIP_Formal_Suffix (BIP_Alloc_Form));
+               end if;
 
-                  --  A match for BIPalloc => 2 has been found
+               --  A match for BIPalloc => 2 has been found
 
-                  if Chars (Formal) = Access_Nam
-                    and then Nkind (Actual) = N_Integer_Literal
-                    and then Intval (Actual) = Uint_2
-                  then
-                     return True;
-                  end if;
+               if Chars (Formal) = Alloc_Nam
+                 and then Nkind (Actual) = N_Integer_Literal
+                 and then Intval (Actual) = Uint_2
+               then
+                  return True;
                end if;
+            end if;
 
-               Next (Param);
-            end loop;
-         end;
+            Next (Param);
+         end loop;
       end if;
 
       return False;
@@ -5274,10 +5342,10 @@ package body Exp_Util is
    begin
       return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
                or else
-             (Is_Private_Type (T) and then Present (Full_View (T))
-               and then not Is_Tagged_Type (Full_View (T))
-               and then Is_Derived_Type (Full_View (T))
-               and then Etype (Full_View (T)) /= T);
+                 (Is_Private_Type (T) and then Present (Full_View (T))
+                   and then not Is_Tagged_Type (Full_View (T))
+                   and then Is_Derived_Type (Full_View (T))
+                   and then Etype (Full_View (T)) /= T);
    end Is_Untagged_Derivation;
 
    ---------------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 54e051b447b..2f316ddb8d1 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -127,6 +127,12 @@ package Exp_Util is
    --  Assoc_Node must be a node in a list. Same as Insert_Action but the
    --  action will be inserted after N in a manner that is compatible with
    --  the transient scope mechanism.
+   --
+   --  Note: If several successive calls to Insert_Action_After are made for
+   --  the same node, they will each in turn be inserted just after the node.
+   --  This means they will end up being executed in reverse order. Use the
+   --  call to Insert_Actions_After to insert a list of actions to be executed
+   --  in the sequence in which they are given in the list.
 
    procedure Insert_Actions_After
      (Assoc_Node  : Node_Id;
@@ -575,6 +581,12 @@ package Exp_Util is
    function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean;
    --  Determine whether node Expr denotes a non build-in-place function call
 
+   function Is_Object_Access_BIP_Func_Call
+      (Expr   : Node_Id;
+       Obj_Id : Entity_Id) return Boolean;
+   --  Determine if Expr denotes a build-in-place function which stores its
+   --  result in the BIPaccess actual parameter whose prefix must match Obj_Id.
+
    function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
    --  Node N is an object reference. This function returns True if it is
    --  possible that the object may not be aligned according to the normal
diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb
index 82da0655c4c..6383e818b14 100644
--- a/gcc/ada/gnatbind.adb
+++ b/gcc/ada/gnatbind.adb
@@ -672,7 +672,7 @@ begin
       if Argument_Count = 0 then
          Bindusg.Display;
       else
-         Write_Line ("try `gnatbind --help` for more information.");
+         Write_Line ("try ""gnatbind --help"" for more information.");
       end if;
 
       Exit_Program (E_Fatal);
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 1a02abf2ffc..b6023637575 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2366,11 +2366,14 @@ package body Sem_Ch3 is
 
       --  Analyze the contracts of subprogram declarations, subprogram bodies
       --  and variables now due to the delayed visibility requirements of their
-      --  aspects.
+      --  aspects. Skip analysis if the declaration already has an error.
 
       Decl := First (L);
       while Present (Decl) loop
-         if Nkind (Decl) = N_Object_Declaration then
+         if Error_Posted (Decl) then
+            null;
+
+         elsif Nkind (Decl) = N_Object_Declaration then
             Analyze_Object_Contract (Defining_Entity (Decl));
 
          elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 7598d5c9eea..2bc1ea03e07 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -706,6 +706,14 @@ package body Sem_Ch8 is
             Error_Msg_N ("within its scope, generic denotes its instance", N);
          end if;
 
+         --  For subprograms, propagate the Intrinsic flag, to allow, e.g.
+         --  renamings and subsequent instantiations of Unchecked_Conversion.
+
+         if Ekind_In (Old_P, E_Generic_Function, E_Generic_Procedure) then
+            Set_Is_Intrinsic_Subprogram
+              (New_P, Is_Intrinsic_Subprogram (Old_P));
+         end if;
+
          Check_Library_Unit_Renaming (N, Old_P);
       end if;
 
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index f2ad1ec6f45..9a55e8cc65a 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -2249,13 +2249,30 @@ package body Sprint is
 
                   --  Print type, we used to print the Object_Definition from
                   --  the node, but it is much more useful to print the Etype
-                  --  of the defining identifier. For example, this will be a
-                  --  clear reference to the Itype with the bounds in the case
-                  --  of an unconstrained array type like String. The object
-                  --  after all is constrained, even if its nominal subtype is
+                  --  of the defining identifier for the case where the nominal
+                  --  type is an unconstrained array type. For example, this
+                  --  will be a clear reference to the Itype with the bounds
+                  --  in the case of a type like String. The object after
+                  --  all is constrained, even if its nominal subtype is
                   --  unconstrained.
 
-                  Sprint_Node (Etype (Def_Id));
+                  declare
+                     Odef : constant Node_Id := Object_Definition (Node);
+
+                  begin
+                     if Nkind (Odef) = N_Identifier
+                       and then Is_Array_Type (Etype (Odef))
+                       and then not Is_Constrained (Etype (Odef))
+                       and then Present (Etype (Def_Id))
+                     then
+                        Sprint_Node (Etype (Def_Id));
+
+                        --  In other cases, the nominal type is fine to print
+
+                     else
+                        Sprint_Node (Odef);
+                     end if;
+                  end;
 
                   if Present (Expression (Node)) then
                      Write_Str (" := ");