[multiple changes]

2012-10-01  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch3.adb (Analyze_Declarations): Remove the specialized
	code which prevents freezing when the declarative list contains
	a _postconditions body. This is no longer needed because the
	body is now inserted at the end of the declarations.
	* sem_ch6.adb (Insert_After_Last_Declaration): New routine.
	(Insert_Before_First_Source_Declaration): Removed.
	(Process_PPCs): Insert the _postconditions body at the end of
	the declarative list to prevent premature freezing of types that
	appear in the declarations.

2012-10-01  Robert Dewar  <dewar@adacore.com>

	* sem_aggr.adb, sem_dim.adb: Minor reformatting.

From-SVN: r191911

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 6b2c9dfef1b5d85a0aa1680a9c8367e48eeb8229..5de322c3b9f12c9cd528e85a1d861c185aa723d6 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,19 @@
+2012-10-01  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * sem_ch3.adb (Analyze_Declarations): Remove the specialized
+       code which prevents freezing when the declarative list contains
+       a _postconditions body. This is no longer needed because the
+       body is now inserted at the end of the declarations.
+       * sem_ch6.adb (Insert_After_Last_Declaration): New routine.
+       (Insert_Before_First_Source_Declaration): Removed.
+       (Process_PPCs): Insert the _postconditions body at the end of
+       the declarative list to prevent premature freezing of types that
+       appear in the declarations.
+
+2012-10-01  Robert Dewar  <dewar@adacore.com>
+
+       * sem_aggr.adb, sem_dim.adb: Minor reformatting.
+
 2012-10-01  Ed Schonberg  <schonberg@adacore.com>
 
        * sem_prag.adb (Process_Convention, Process_Import_Or_Interface):

diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index f0e90ee19e3576b0199a94d34ffe687654209512..c8167f1ed264b782872c5a53d1e10769d4935fd1 100644 (file)
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -2550,7 +2550,7 @@ package body Sem_Aggr is
              Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N))));
       end if;
 
-      --  Check the dimensions of each component in the array aggregate.
+      --  Check the dimensions of each component in the array aggregate
 
       Analyze_Dimension_Array_Aggregate (N, Component_Typ);
 
@@ -3392,6 +3392,7 @@ package body Sem_Aggr is
             --  propagate here the dimensions form Expr to New_Expr.
 
             Move_Dimensions (Expr, New_Expr);
+
          else
             New_Expr := Expr;
          end if;
@@ -4504,7 +4505,7 @@ package body Sem_Aggr is
          Rewrite (N, New_Aggregate);
       end Step_8;
 
-      --  Check the dimensions of the components in the record aggregate.
+      --  Check the dimensions of the components in the record aggregate
 
       Analyze_Dimension_Extension_Or_Record_Aggregate (N);
    end Resolve_Record_Aggregate;

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 78ec8a0ba95a4e2706269fb4848600973e5c47d1..483e7055f03555300555c2eee41158ebce3a0067 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2152,9 +2152,7 @@ package body Sem_Ch3 is
          --  explicitly checked that all required types are properly frozen,
          --  and we do not cause general freezing here. This special circuit
          --  is used when the encountered body is marked as having already
-         --  been analyzed (although we must take into account the special
-         --  case of the internally generated subprogram _postconditions,
-         --  may not have been analyzed yet)
+         --  been analyzed.
 
          --  In all other cases (bodies that come from source, and expander
          --  generated bodies that have not been analyzed yet), freeze all
@@ -2170,11 +2168,6 @@ package body Sem_Ch3 is
                                           N_Task_Body)
                        or else
                      Nkind (Next_Node) in N_Body_Stub)
-           and then not
-             (Ada_Version = Ada_2012
-                and then Nkind (Next_Node) = N_Subprogram_Body
-                and then Chars (Defining_Entity (Next_Node))
-                           = Name_uPostconditions)
          then
             Adjust_D;
             Freeze_All (Freeze_From, D);

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index cdb39fb35bed8a2316858c92e52acae4096970ce..4144fe049223383a42ba8c0bde260a71c9766a15 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -11091,8 +11091,8 @@ package body Sem_Ch6 is
       --  references to parameters of the inherited subprogram to point to the
       --  corresponding parameters of the current subprogram.
 
-      procedure Insert_Before_First_Source_Declaration (Nod : Node_Id);
-      --  Insert node Nod before the first source declaration of the context
+      procedure Insert_After_Last_Declaration (Nod : Node_Id);
+      --  Insert node Nod after the last declaration of the context
 
       function Invariants_Or_Predicates_Present return Boolean;
       --  Determines if any invariants or predicates are present for any OUT
@@ -11285,35 +11285,20 @@ package body Sem_Ch6 is
          return CP;
       end Grab_PPC;
 
-      --------------------------------------------
-      -- Insert_Before_First_Source_Declaration --
-      --------------------------------------------
+      -----------------------------------
+      -- Insert_After_Last_Declaration --
+      -----------------------------------
 
-      procedure Insert_Before_First_Source_Declaration (Nod : Node_Id) is
+      procedure Insert_After_Last_Declaration (Nod : Node_Id) is
          Decls : constant List_Id := Declarations (N);
-         Decl  : Node_Id;
 
       begin
          if No (Decls) then
             Set_Declarations (N, New_List (Nod));
          else
-            Decl := First (Decls);
-
-            while Present (Decl) loop
-               if Comes_From_Source (Decl) then
-                  exit;
-               end if;
-
-               Next (Decl);
-            end loop;
-
-            if No (Decl) then
-               Append_To (Decls, Nod);
-            else
-               Insert_Before (Decl, Nod);
-            end if;
+            Append_To (Decls, Nod);
          end if;
-      end Insert_Before_First_Source_Declaration;
+      end Insert_After_Last_Declaration;
 
       --------------------------------------
       -- Invariants_Or_Predicates_Present --
@@ -11797,12 +11782,26 @@ package body Sem_Ch6 is
             --  The entity for the _Postconditions procedure
 
          begin
-            --  Insert the corresponding body of a post condition pragma before
-            --  the first source declaration of the context. This ensures that
-            --  any [sub]types generated in relation to the formals of the
-            --  subprogram are still visible in the _postcondition body.
-
-            Insert_Before_First_Source_Declaration (
+            --  Insert the corresponding body of a post condition pragma after
+            --  the last declaration of the context. This ensures that the body
+            --  will not cause any premature freezing as it may mention types:
+
+            --    procedure Proc (Obj : Array_Typ) is
+            --       procedure _postconditions is
+            --       begin
+            --          ... Obj ...
+            --       end _postconditions;
+
+            --       subtype T is Array_Typ (Obj'First (1) .. Obj'Last (1));
+            --    begin
+
+            --  In the example above, Obj is of type T but the incorrect
+            --  placement of _postconditions will cause a crash in gigi due to
+            --  an out of order reference. The body of _postconditions must be
+            --  placed after the declaration of Temp to preserve correct
+            --  visibility.
+
+            Insert_After_Last_Declaration (
               Make_Subprogram_Body (Loc,
                 Specification =>
                   Make_Procedure_Specification (Loc,

diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb
index 8a8b1957f29ee86b86bb9ee84a1feb4e6a8cc6fd..d7526076a3466da0528c3145541e7521e491e3d5 100644 (file)
--- a/gcc/ada/sem_dim.adb
+++ b/gcc/ada/sem_dim.adb
@@ -1132,9 +1132,7 @@ package body Sem_Dim is
       --  Aspect is an Ada 2012 feature. Note that there is no need to check
       --  dimensions for nodes that don't come from source.
 
-      if Ada_Version < Ada_2012
-        or else not Comes_From_Source (N)
-      then
+      if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
          return;
       end if;
 
@@ -1226,6 +1224,7 @@ package body Sem_Dim is
       end if;
 
       while Present (Comp) loop
+
          --  Get the expression from the component
 
          if Nkind (Comp) = N_Component_Association then
@@ -1255,10 +1254,12 @@ package body Sem_Dim is
                Error_Detected := True;
             end if;
 
-            Error_Msg_N ("\expected dimension " &
-                         Dimensions_Msg_Of (Comp_Typ) & ", found " &
-                         Dimensions_Msg_Of (Expr),
-                         Expr);
+            Error_Msg_N
+              ("\expected dimension "
+                & Dimensions_Msg_Of (Comp_Typ)
+                & ", found "
+                & Dimensions_Msg_Of (Expr),
+               Expr);
          end if;
 
          --  Look at the named components right after the positional components
@@ -1301,7 +1302,7 @@ package body Sem_Dim is
       is
       begin
          Error_Msg_N ("dimensions mismatch in assignment", N);
-         Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N);
+         Error_Msg_N ("\left-hand side "  & Dimensions_Msg_Of (Lhs, True), N);
          Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N);
       end Error_Dim_Msg_For_Assignment_Statement;
 
@@ -1337,7 +1338,7 @@ package body Sem_Dim is
                        "dimensions",
                        N,
                        Entity (N));
-         Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N);
+         Error_Msg_N ("\left operand "  & Dimensions_Msg_Of (L, True), N);
          Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N);
       end Error_Dim_Msg_For_Binary_Op;
 
@@ -1551,6 +1552,8 @@ package body Sem_Dim is
                          Ada_Numerics_Generic_Elementary_Functions);
             end Is_Elementary_Function_Entity;
 
+         --  Start of processing for Elementary_Function_Calls
+
          begin
             --  Get the original subprogram entity following the renaming chain
 
@@ -1561,6 +1564,7 @@ package body Sem_Dim is
             --  Check the call is an Elementary function call
 
             if Is_Elementary_Function_Entity (Ent) then
+
                --  Sqrt function call case
 
                if Chars (Ent) = Name_Sqrt then
@@ -1585,11 +1589,10 @@ package body Sem_Dim is
 
                else
                   Actual := First_Actual (N);
-
                   while Present (Actual) loop
                      if Exists (Dimensions_Of (Actual)) then
-                        --  Check if an error has already been encountered so
-                        --  far.
+
+                        --  Check if error has already been encountered so far
 
                         if not Error_Detected then
                            Error_Msg_NE ("dimensions mismatch in call of&",
@@ -1682,9 +1685,10 @@ package body Sem_Dim is
          Expr : Node_Id) is
       begin
          Error_Msg_N ("dimensions mismatch in component declaration", N);
-         Error_Msg_N ("\expected dimension " &
-                      Dimensions_Msg_Of (Etyp) & ", found " &
-                      Dimensions_Msg_Of (Expr),
+         Error_Msg_N ("\expected dimension "
+                       & Dimensions_Msg_Of (Etyp)
+                       & ", found "
+                       & Dimensions_Msg_Of (Expr),
                       Expr);
       end Error_Dim_Msg_For_Component_Declaration;
 
@@ -1703,9 +1707,8 @@ package body Sem_Dim is
             --  dimensionless to indicate the literal is treated as if its
             --  dimension matches the type dimension.
 
-            if Nkind_In (Original_Node (Expr),
-                             N_Real_Literal,
-                             N_Integer_Literal)
+            if Nkind_In (Original_Node (Expr), N_Real_Literal,
+                                               N_Integer_Literal)
             then
                Dim_Warning_For_Numeric_Literal (Expr, Etyp);
 
@@ -1729,7 +1732,7 @@ package body Sem_Dim is
    procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is
       Return_Ent       : constant Entity_Id := Return_Statement_Entity (N);
       Return_Etyp      : constant Entity_Id :=
-                           Etype (Return_Applies_To (Return_Ent));
+        Etype (Return_Applies_To (Return_Ent));
       Return_Obj_Decls : constant List_Id := Return_Object_Declarations (N);
       Return_Obj_Decl  : Node_Id;
       Return_Obj_Id    : Entity_Id;
@@ -1754,9 +1757,10 @@ package body Sem_Dim is
       is
       begin
          Error_Msg_N ("dimensions mismatch in extended return statement", N);
-         Error_Msg_N ("\expected dimension " &
-                      Dimensions_Msg_Of (Return_Etyp) & ", found " &
-                      Dimensions_Msg_Of (Return_Obj_Typ),
+         Error_Msg_N ("\expected dimension "
+                       & Dimensions_Msg_Of (Return_Etyp)
+                       & ", found "
+                       & Dimensions_Msg_Of (Return_Obj_Typ),
                       N);
       end Error_Dim_Msg_For_Extended_Return_Statement;
 
@@ -1765,10 +1769,9 @@ package body Sem_Dim is
    begin
       if Present (Return_Obj_Decls) then
          Return_Obj_Decl := First (Return_Obj_Decls);
-
          while Present (Return_Obj_Decl) loop
             if Nkind (Return_Obj_Decl) = N_Object_Declaration then
-               Return_Obj_Id  := Defining_Identifier (Return_Obj_Decl);
+               Return_Obj_Id := Defining_Identifier (Return_Obj_Decl);
 
                if Is_Return_Object (Return_Obj_Id) then
                   Return_Obj_Typ := Etype (Return_Obj_Id);
@@ -1795,7 +1798,7 @@ package body Sem_Dim is
    -----------------------------------------------------
 
    procedure Analyze_Dimension_Extension_Or_Record_Aggregate (N : Node_Id) is
-      Comp     : Node_Id := First (Component_Associations (N));
+      Comp     : Node_Id;
       Comp_Id  : Entity_Id;
       Comp_Typ : Entity_Id;
       Expr     : Node_Id;
@@ -1808,12 +1811,11 @@ package body Sem_Dim is
       --  Aspect is an Ada 2012 feature. Note that there is no need to check
       --  dimensions for aggregates that don't come from source.
 
-      if Ada_Version < Ada_2012
-        or else not Comes_From_Source (N)
-      then
+      if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
          return;
       end if;
 
+      Comp := First (Component_Associations (N));
       while Present (Comp) loop
          Comp_Id  := Entity (First (Choices (Comp)));
          Comp_Typ := Etype (Comp_Id);
@@ -1828,29 +1830,33 @@ package body Sem_Dim is
             --  dimensions of the component mismatch.
 
             if Dimensions_Of (Expr) /= Dimensions_Of (Comp_Typ) then
+
                --  Check if an error has already been encountered so far
 
                if not Error_Detected then
+
                   --  Extension aggregate case
 
                   if Nkind (N) = N_Extension_Aggregate then
-                     Error_Msg_N ("dimensions mismatch in extension aggregate",
-                                  N);
+                     Error_Msg_N
+                       ("dimensions mismatch in extension aggregate", N);
 
                   --  Record aggregate case
 
                   else
-                     Error_Msg_N ("dimensions mismatch in record aggregate",
-                                  N);
+                     Error_Msg_N
+                       ("dimensions mismatch in record aggregate", N);
                   end if;
 
                   Error_Detected := True;
                end if;
 
-               Error_Msg_N ("\expected dimension " &
-                            Dimensions_Msg_Of (Comp_Typ) & ", found " &
-                            Dimensions_Msg_Of (Expr),
-                            Comp);
+               Error_Msg_N
+                 ("\expected dimension "
+                   & Dimensions_Msg_Of (Comp_Typ)
+                   & ", found "
+                   & Dimensions_Msg_Of (Expr),
+                  Comp);
             end if;
          end if;
 
@@ -1871,14 +1877,11 @@ package body Sem_Dim is
       --  Aspect is an Ada 2012 feature. Note that there is no need to check
       --  dimensions for sub specs that don't come from source.
 
-      if Ada_Version < Ada_2012
-        or else not Comes_From_Source (N)
-      then
+      if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
          return;
       end if;
 
       Formal := First (Formals);
-
       while Present (Formal) loop
          Typ         := Parameter_Type (Formal);
          Dims_Of_Typ := Dimensions_Of  (Typ);
@@ -1893,9 +1896,8 @@ package body Sem_Dim is
 
                if Present (Expr)
                  and then Dims_Of_Typ /= Dimensions_Of (Expr)
-                 and then Nkind_In (Original_Node (Expr),
-                                       N_Real_Literal,
-                                       N_Integer_Literal)
+                 and then Nkind_In (Original_Node (Expr), N_Real_Literal,
+                                                          N_Integer_Literal)
                then
                   Dim_Warning_For_Numeric_Literal (Expr, Etype (Typ));
                end if;
@@ -1990,10 +1992,12 @@ package body Sem_Dim is
          Expr : Node_Id) is
       begin
          Error_Msg_N ("dimensions mismatch in object declaration", N);
-         Error_Msg_N ("\expected dimension " &
-                      Dimensions_Msg_Of (Etyp) & ", found " &
-                      Dimensions_Msg_Of (Expr),
-                      Expr);
+         Error_Msg_N
+           ("\expected dimension "
+             & Dimensions_Msg_Of (Etyp)
+             & ", found "
+             & Dimensions_Msg_Of (Expr),
+            Expr);
       end Error_Dim_Msg_For_Object_Declaration;
 
    --  Start of processing for Analyze_Dimension_Object_Declaration
@@ -2007,22 +2011,21 @@ package body Sem_Dim is
          --  Check dimensions match
 
          if Dim_Of_Expr /= Dim_Of_Etyp then
+
             --  Numeric literal case. Issue a warning if the object type is not
             --  dimensionless to indicate the literal is treated as if its
             --  dimension matches the type dimension.
 
-            if Nkind_In (Original_Node (Expr),
-                             N_Real_Literal,
-                             N_Integer_Literal)
+            if Nkind_In (Original_Node (Expr), N_Real_Literal,
+                                               N_Integer_Literal)
             then
                Dim_Warning_For_Numeric_Literal (Expr, Etyp);
 
-            --  Case where the object is a constant whose type is a dimensioned
-            --  type.
+            --  Case of object is a constant whose type is a dimensioned type
 
             elsif Constant_Present (N) and then not Exists (Dim_Of_Etyp) then
-               --  Propagate the dimension from the expression to the object
-               --  entity
+
+               --  Propagate dimension from expression to object entity
 
                Set_Dimensions (Id, Dim_Of_Expr);
 
@@ -2064,10 +2067,12 @@ package body Sem_Dim is
          Renamed_Name : Node_Id) is
       begin
          Error_Msg_N ("dimensions mismatch in object renaming declaration", N);
-         Error_Msg_N ("\expected dimension " &
-                      Dimensions_Msg_Of (Sub_Mark) & ", found " &
-                      Dimensions_Msg_Of (Renamed_Name),
-                      Renamed_Name);
+         Error_Msg_N
+           ("\expected dimension "
+             & Dimensions_Msg_Of (Sub_Mark)
+             & ", found "
+             & Dimensions_Msg_Of (Renamed_Name),
+            Renamed_Name);
       end Error_Dim_Msg_For_Object_Renaming_Declaration;
 
    --  Start of processing for Analyze_Dimension_Object_Renaming_Declaration
@@ -2110,10 +2115,12 @@ package body Sem_Dim is
       is
       begin
          Error_Msg_N ("dimensions mismatch in return statement", N);
-         Error_Msg_N ("\expected dimension " &
-                      Dimensions_Msg_Of (Return_Etyp) & ", found " &
-                      Dimensions_Msg_Of (Expr),
-                      Expr);
+         Error_Msg_N
+           ("\expected dimension "
+             & Dimensions_Msg_Of (Return_Etyp)
+             & ", found "
+             & Dimensions_Msg_Of (Expr),
+            Expr);
       end Error_Dim_Msg_For_Simple_Return_Statement;
 
    --  Start of processing for Analyze_Dimension_Simple_Return_Statement
@@ -2148,8 +2155,9 @@ package body Sem_Dim is
             --  it cannot inherit a dimension from its subtype.
 
             if Exists (Dims_Of_Id) then
-               Error_Msg_N ("subtype& already" & Dimensions_Msg_Of (Id, True),
-                            N);
+               Error_Msg_N
+                 ("subtype& already" & Dimensions_Msg_Of (Id, True), N);
+
             else
                Set_Dimensions (Id, Dims_Of_Etyp);
                Set_Symbol (Id, Symbol_Of (Etyp));
@@ -2842,7 +2850,6 @@ package body Sem_Dim is
 
             if Exists (Symbol_Of (Etyp)) then
                Symbols := Symbol_Of (Etyp);
-
             else
                Symbols := From_Dim_To_Str_Of_Unit_Symbols
                             (Dims_Of_Actual, System_Of (Base_Type (Etyp)));
@@ -3334,7 +3341,6 @@ package body Sem_Dim is
 
    begin
       Start_String;
-
       while Belong_To_Numeric_Literal (C) loop
          Store_String_Char (C);
          Src_Ptr := Src_Ptr + 1;
@@ -3350,11 +3356,9 @@ package body Sem_Dim is
 
    function Symbol_Of (E : Entity_Id) return String_Id is
       Subtype_Symbol : constant String_Id := Symbol_Table.Get (E);
-
    begin
       if Subtype_Symbol /= No_String then
          return Subtype_Symbol;
-
       else
          return From_Dim_To_Str_Of_Unit_Symbols
                   (Dimensions_Of (E), System_Of (Base_Type (E)));
@@ -3388,4 +3392,5 @@ package body Sem_Dim is
 
       return Null_System;
    end System_Of;
+
 end Sem_Dim;