[multiple changes]

2014-08-04  Olivier Hainque  <hainque@adacore.com>

	* a-comutr.ads: Set Root_Node_Type'Alignment to
	Standard'Maximum_Alignment, so that it is at least as large as
	the max default for Tree_Node_Type'Alignment.

2014-08-04  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch3.adb (Freeze_Type): Remove the generation and inheritance
	of the default initial condition procedure [body].
	* sem_ch3.adb (Analyze_Declarations): Create the bodies of
	all default initial condition procedures at the end of private
	declaration analysis.
	* sem_util.adb (Build_Default_Init_Cond_Procedure_Bodies): New
	routine.
	(Build_Default_Init_Cond_Procedure_Body): Merged in the
	processing of routine Build_Default_Init_Cond_Procedure_Bodies.
	* sem_util.ads (Build_Default_Init_Cond_Procedure_Bodies):
	New routine.
	(Build_Default_Init_Cond_Procedure_Body): Removed.

2014-08-04  Ed Schonberg  <schonberg@adacore.com>

	* sem_elab.adb (Check_Elab_Call): Do not check a call to a
	postcondtion.
	* exp_ch6.adb (Expand_Call): Clarify handling of inserted
	postcondition call.

From-SVN: r213580

8 files changed, 217 insertions, 125 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 02b59b2..49127ff 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,31 @@
+2014-08-04  Olivier Hainque  <hainque@adacore.com>
+
+	* a-comutr.ads: Set Root_Node_Type'Alignment to
+	Standard'Maximum_Alignment, so that it is at least as large as
+	the max default for Tree_Node_Type'Alignment.
+
+2014-08-04  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch3.adb (Freeze_Type): Remove the generation and inheritance
+	of the default initial condition procedure [body].
+	* sem_ch3.adb (Analyze_Declarations): Create the bodies of
+	all default initial condition procedures at the end of private
+	declaration analysis.
+	* sem_util.adb (Build_Default_Init_Cond_Procedure_Bodies): New
+	routine.
+	(Build_Default_Init_Cond_Procedure_Body): Merged in the
+	processing of routine Build_Default_Init_Cond_Procedure_Bodies.
+	* sem_util.ads (Build_Default_Init_Cond_Procedure_Bodies):
+	New routine.
+	(Build_Default_Init_Cond_Procedure_Body): Removed.
+
+2014-08-04  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_elab.adb (Check_Elab_Call): Do not check a call to a
+	postcondtion.
+	* exp_ch6.adb (Expand_Call): Clarify handling of inserted
+	postcondition call.
+
 2014-08-04  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_prag.adb (Analyze_Pragma): Ensure that an
diff --git a/gcc/ada/a-comutr.ads b/gcc/ada/a-comutr.ads
index 6e0aa9a..c1a3dc8 100644
--- a/gcc/ada/a-comutr.ads
+++ b/gcc/ada/a-comutr.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2014, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -308,17 +308,16 @@ package Ada.Containers.Multiway_Trees is
       Process : not null access procedure (Position : Cursor));
 
 private
-
    --  A node of this multiway tree comprises an element and a list of children
    --  (that are themselves trees). The root node is distinguished because it
    --  contains only children: it does not have an element itself.
-   --
-   --  This design feature puts two design goals in tension:
+
+   --  This design feature puts two design goals in tension with one another:
    --   (1) treat the root node the same as any other node
    --   (2) not declare any objects of type Element_Type unnecessarily
-   --
-   --  To satisfy (1), we could simply declare the Root node of the tree using
-   --  the normal Tree_Node_Type, but that would mean that (2) is not
+
+   --  To satisfy (1), we could simply declare the Root node of the tree
+   --  using the normal Tree_Node_Type, but that would mean that (2) is not
    --  satisfied. To resolve the tension (in favor of (2)), we declare the
    --  component Root as having a different node type, without an Element
    --  component (thus satisfying goal (2)) but otherwise identical to a normal
@@ -327,11 +326,11 @@ private
    --  normal, non-root node (thus satisfying goal (1)). We make an explicit
    --  check for Root when there is any attempt to manipulate the Element
    --  component of the node (a check required by the RM anyway).
-   --
+
    --  In order to be explicit about node (and pointer) representation, we
-   --  specify that the respective node types have convention C, to ensure that
-   --  the layout of the components of the node records is the same, thus
-   --  guaranteeing that (unchecked) conversions between access types
+   --  specify that the respective node types have convention C, to ensure
+   --  that the layout of the components of the node records is the same,
+   --  thus guaranteeing that (unchecked) conversions between access types
    --  designating each kind of node type is a meaningful conversion.
 
    type Tree_Node_Type;
@@ -366,6 +365,11 @@ private
    end record;
    pragma Convention (C, Root_Node_Type);
 
+   for Root_Node_Type'Alignment use Standard'Maximum_Alignment;
+   --  The alignment has to be large enough to allow Root_Node to Tree_Node
+   --  access value conversions, and Tree_Node_Type's alignment may be bumped
+   --  up by the Element component.
+
    use Ada.Finalization;
 
    --  The Count component of type Tree represents the number of nodes that
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 6eec78a..5e11962 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -7394,20 +7394,6 @@ package body Exp_Ch3 is
          end if;
       end if;
 
-      --  If the type is subject to pragma Default_Initial_Condition, generate
-      --  the body of the procedure which verifies the assertion of the pragma
-      --  at runtime.
-
-      if Has_Default_Init_Cond (Def_Id) then
-         Build_Default_Init_Cond_Procedure_Body (Def_Id);
-
-      --  A derived type inherits the default initial condition procedure from
-      --  its parent type.
-
-      elsif Has_Inherited_Default_Init_Cond (Def_Id) then
-         Inherit_Default_Init_Cond_Procedure (Def_Id);
-      end if;
-
       --  Freeze processing for record types
 
       if Is_Record_Type (Def_Id) then
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 7f11190..82c8787 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -5209,6 +5209,13 @@ package body Exp_Ch6 is
                --  Analyze call, but something goes wrong in some weird cases
                --  and it is not worth worrying about ???
 
+               --  The return statement is handled properly, and the call to
+               --  the postcondition, inserted below, does not require
+               --  information from the body either. However, that call is
+               --  analyzed in the enclosing scope, and an elaboration check
+               --  might improperly be added to it.  A guard in sem_elab is
+               --  needed to prevent that spurious check, see Check_Elab_Call.
+
                Append_To (S, Rtn);
                Set_Analyzed (Rtn);
 
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 424cc69..5b16aa2 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2388,10 +2388,13 @@ package body Sem_Ch3 is
             --  When a package has private declarations, its contract must be
             --  analyzed at the end of the said declarations. This way both the
             --  analysis and freeze actions are properly synchronized in case
-            --  of private type use within the contract.
+            --  of private type use within the contract. Build the bodies of
+            --  the default initial condition procedures for all types subject
+            --  to pragma Default_Initial_Condition.
 
             if L = Private_Declarations (Context) then
                Analyze_Package_Contract (Defining_Entity (Context));
+               Build_Default_Init_Cond_Procedure_Bodies (L);
 
             --  Otherwise the contract is analyzed at the end of the visible
             --  declarations.
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index 296c2a2..e5e29bc 100644
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -1218,6 +1218,17 @@ package body Sem_Elab is
          return;
       end if;
 
+      --  Nothing to do if this is a call to a postcondition, which is always
+      --  within a subprogram body, even though the current scope may be the
+      --  enclosing scope of the subprogram.
+
+      if Nkind (N) = N_Procedure_Call_Statement
+        and then Is_Entity_Name (Name (N))
+        and then Chars (Entity (Name (N))) = Name_uPostconditions
+      then
+         return;
+      end if;
+
       --  Here we have a call at elaboration time which must be checked
 
       if Debug_Flag_LL then
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 71a6429..d55d7c5 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -1252,123 +1252,177 @@ package body Sem_Util is
               Expression   => New_Occurrence_Of (Obj_Id, Loc))));
    end Build_Default_Init_Cond_Call;
 
-   --------------------------------------------
-   -- Build_Default_Init_Cond_Procedure_Body --
-   --------------------------------------------
+   ----------------------------------------------
+   -- Build_Default_Init_Cond_Procedure_Bodies --
+   ----------------------------------------------
 
-   procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is
-      Param_Id : Entity_Id;
-      --  The entity of the formal parameter of the default initial condition
-      --  procedure.
+   procedure Build_Default_Init_Cond_Procedure_Bodies (Priv_Decls : List_Id) is
+      procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id);
+      --  If type Typ is subject to pragma Default_Initial_Condition, build the
+      --  body of the procedure which verifies the assumption of the pragma at
+      --  runtime. The generated body is added after the type declaration.
 
-      procedure Replace_Type_Reference (N : Node_Id);
-      --  Replace a single reference to type Typ with a reference to Param_Id
+      --------------------------------------------
+      -- Build_Default_Init_Cond_Procedure_Body --
+      --------------------------------------------
 
-      ----------------------------
-      -- Replace_Type_Reference --
-      ----------------------------
+      procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is
+         Param_Id : Entity_Id;
+         --  The entity of the sole formal parameter of the default initial
+         --  condition procedure.
 
-      procedure Replace_Type_Reference (N : Node_Id) is
-      begin
-         Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N)));
-      end Replace_Type_Reference;
+         procedure Replace_Type_Reference (N : Node_Id);
+         --  Replace a single reference to type Typ with a reference to formal
+         --  parameter Param_Id.
 
-      procedure Replace_Type_References is
-        new Replace_Type_References_Generic (Replace_Type_Reference);
+         ----------------------------
+         -- Replace_Type_Reference --
+         ----------------------------
 
-      --  Local variables
+         procedure Replace_Type_Reference (N : Node_Id) is
+         begin
+            Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N)));
+         end Replace_Type_Reference;
 
-      Loc       : constant Source_Ptr := Sloc (Typ);
-      Prag      : constant Node_Id    :=
-                    Get_Pragma (Typ, Pragma_Default_Initial_Condition);
-      Proc_Id   : constant Entity_Id  := Default_Init_Cond_Procedure (Typ);
-      Spec_Decl : constant Node_Id    := Unit_Declaration_Node (Proc_Id);
-      Body_Decl : Node_Id;
-      Expr      : Node_Id;
-      Stmt      : Node_Id;
+         procedure Replace_Type_References is
+           new Replace_Type_References_Generic (Replace_Type_Reference);
 
-   --  Start of processing for Build_Default_Init_Cond_Procedure
+         --  Local variables
 
-   begin
-      --  The procedure should be generated only for types subject to pragma
-      --  Default_Initial_Condition. Types that inherit the pragma do not get
-      --  this specialized procedure.
+         Loc       : constant Source_Ptr := Sloc (Typ);
+         Prag      : constant Node_Id    :=
+                       Get_Pragma (Typ, Pragma_Default_Initial_Condition);
+         Proc_Id   : constant Entity_Id  := Default_Init_Cond_Procedure (Typ);
+         Spec_Decl : constant Node_Id    := Unit_Declaration_Node (Proc_Id);
+         Body_Decl : Node_Id;
+         Expr      : Node_Id;
+         Stmt      : Node_Id;
 
-      pragma Assert (Has_Default_Init_Cond (Typ));
-      pragma Assert (Present (Prag));
-      pragma Assert (Present (Proc_Id));
+      --  Start of processing for Build_Default_Init_Cond_Procedure
 
-      --  Nothing to do if the body was already built
+      begin
+         --  The procedure should be generated only for [sub]types subject to
+         --  pragma Default_Initial_Condition. Types that inherit the pragma do
+         --  not get this specialized procedure.
 
-      if Present (Corresponding_Body (Spec_Decl)) then
-         return;
-      end if;
+         pragma Assert (Has_Default_Init_Cond (Typ));
+         pragma Assert (Present (Prag));
+         pragma Assert (Present (Proc_Id));
+
+         --  Nothing to do if the body was already built
+
+         if Present (Corresponding_Body (Spec_Decl)) then
+            return;
+         end if;
 
-      Param_Id := First_Formal (Proc_Id);
+         Param_Id := First_Formal (Proc_Id);
 
-      --  The pragma has an argument. Note that the argument is analyzed after
-      --  all references to the current instance of the type are replaced.
+         --  The pragma has an argument. Note that the argument is analyzed
+         --  after all references to the current instance of the type are
+         --  replaced.
 
-      if Present (Pragma_Argument_Associations (Prag)) then
-         Expr := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
+         if Present (Pragma_Argument_Associations (Prag)) then
+            Expr :=
+              Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
 
-         if Nkind (Expr) = N_Null then
-            Stmt := Make_Null_Statement (Loc);
+            if Nkind (Expr) = N_Null then
+               Stmt := Make_Null_Statement (Loc);
+
+            --  Preserve the original argument of the pragma by replicating it.
+            --  Replace all references to the current instance of the type with
+            --  references to the formal parameter.
+
+            else
+               Expr := New_Copy_Tree (Expr);
+               Replace_Type_References (Expr, Typ);
+
+               --  Generate:
+               --    pragma Check (Default_Initial_Condition, <Expr>);
+
+               Stmt :=
+                 Make_Pragma (Loc,
+                   Pragma_Identifier            =>
+                     Make_Identifier (Loc, Name_Check),
+
+                   Pragma_Argument_Associations => New_List (
+                     Make_Pragma_Argument_Association (Loc,
+                       Expression =>
+                         Make_Identifier (Loc,
+                           Chars => Name_Default_Initial_Condition)),
+                     Make_Pragma_Argument_Association (Loc,
+                       Expression => Expr)));
+            end if;
 
-         --  Preserve the original argument of the pragma by replicating it.
-         --  Replace all references to the current instance of the type with
-         --  references to the formal parameter.
+         --  Otherwise the pragma appears without an argument
 
          else
-            Expr := New_Copy_Tree (Expr);
-            Replace_Type_References (Expr, Typ);
-
-            --  Generate:
-            --    pragma Check (Default_Initial_Condition, <Expr>);
-
-            Stmt :=
-              Make_Pragma (Loc,
-                Pragma_Identifier            =>
-                  Make_Identifier (Loc, Name_Check),
-
-                Pragma_Argument_Associations => New_List (
-                  Make_Pragma_Argument_Association (Loc,
-                    Expression =>
-                      Make_Identifier (Loc, Name_Default_Initial_Condition)),
-                  Make_Pragma_Argument_Association (Loc,
-                    Expression => Expr)));
+            Stmt := Make_Null_Statement (Loc);
          end if;
 
-      --  Otherwise the pragma appears without an argument
+         --  Generate:
+         --    procedure <Typ>Default_Init_Cond (I : <Typ>) is
+         --    begin
+         --       <Stmt>;
+         --    end <Typ>Default_Init_Cond;
 
-      else
-         Stmt := Make_Null_Statement (Loc);
-      end if;
+         Body_Decl :=
+           Make_Subprogram_Body (Loc,
+             Specification              =>
+               Copy_Separate_Tree (Specification (Spec_Decl)),
+             Declarations               => Empty_List,
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc,
+                 Statements => New_List (Stmt)));
 
-      --  Generate:
-      --    procedure <Typ>Default_Init_Cond (I : <Typ>) is
-      --    begin
-      --       <Stmt>;
-      --    end <Typ>Default_Init_Cond;
-
-      Body_Decl :=
-        Make_Subprogram_Body (Loc,
-          Specification              =>
-            Copy_Separate_Tree (Specification (Spec_Decl)),
-          Declarations               => Empty_List,
-          Handled_Statement_Sequence =>
-            Make_Handled_Sequence_Of_Statements (Loc,
-              Statements => New_List (Stmt)));
-
-      --  Link the spec and body of the default initial condition procedure
-      --  to prevent the generation of a duplicate body in case there is an
-      --  attempt to freeze the related type again.
-
-      Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl));
-      Set_Corresponding_Spec (Body_Decl, Proc_Id);
-
-      Append_Freeze_Action (Typ, Body_Decl);
-   end Build_Default_Init_Cond_Procedure_Body;
+         --  Link the spec and body of the default initial condition procedure
+         --  to prevent the generation of a duplicate body.
+
+         Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl));
+         Set_Corresponding_Spec (Body_Decl, Proc_Id);
+
+         Insert_After_And_Analyze (Declaration_Node (Typ), Body_Decl);
+      end Build_Default_Init_Cond_Procedure_Body;
+
+      --  Local variables
+
+      Decl : Node_Id;
+      Typ  : Entity_Id;
+
+   --  Start of processing for Build_Default_Init_Cond_Procedure_Bodies
+
+   begin
+      --  Inspect the private declarations looking for [sub]type declarations
+
+      Decl := First (Priv_Decls);
+      while Present (Decl) loop
+         if Nkind_In (Decl, N_Full_Type_Declaration,
+                            N_Subtype_Declaration)
+         then
+            Typ := Defining_Entity (Decl);
+
+            --  Guard against partially decorate types due to previous errors
+
+            if Is_Type (Typ) then
+
+               --  If the type is subject to pragma Default_Initial_Condition,
+               --  generate the body of the internal procedure which verifies
+               --  the assertion of the pragma at runtime.
+
+               if Has_Default_Init_Cond (Typ) then
+                  Build_Default_Init_Cond_Procedure_Body (Typ);
+
+               --  A derived type inherits the default initial condition
+               --  procedure from its parent type.
+
+               elsif Has_Inherited_Default_Init_Cond (Typ) then
+                  Inherit_Default_Init_Cond_Procedure (Typ);
+               end if;
+            end if;
+         end if;
+
+         Next (Decl);
+      end loop;
+   end Build_Default_Init_Cond_Procedure_Bodies;
 
    ---------------------------------------------------
    -- Build_Default_Init_Cond_Procedure_Declaration --
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index b567e43..2892916 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -218,11 +218,10 @@ package Sem_Util is
    --  Build a call to the default initial condition procedure of type Typ with
    --  Obj_Id as the actual parameter.
 
-   procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id);
-   --  If private type Typ is subject to pragma Default_Initial_Condition,
-   --  build the body of the procedure which verifies the assumption of the
-   --  pragma at runtime. The generated body is added to the freeze actions
-   --  of the type.
+   procedure Build_Default_Init_Cond_Procedure_Bodies (Priv_Decls : List_Id);
+   --  Inspect the contents of private declarations Priv_Decls and build the
+   --  bodies the default initial condition procedures for all types subject
+   --  to pragma Default_Initial_Condition.
 
    procedure Build_Default_Init_Cond_Procedure_Declaration (Typ : Entity_Id);
    --  If private type Typ is subject to pragma Default_Initial_Condition,