[multiple changes]

2013-04-23  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb (Fix_Error): Rewrite to do more accurate job
	of getting proper name in the case where pragma comes from
	aspect.
	* sem_ch3.adb, sinfo.ads, par-ch6.adb, exp_ch6.adb: Minor reformatting.

2013-04-23  Yannick Moy  <moy@adacore.com>

	* sem_ch6.adb (Process_PPCs): Do not filter postconditions based on
	applicable policy.

2013-04-23  Thomas Quinot  <quinot@adacore.com>

	* par_sco.adb (Traverse_Aux_Decls): Minor code reorganization.

2013-04-23  Doug Rupp  <rupp@adacore.com>

	* init.c: Move facility macros outside IN_RTS.

2013-04-23  Thomas Quinot  <quinot@adacore.com>

	* freeze.adb (Freeze_Entity): For the case of a bit-packed
	array time that is known at compile time to have more that
	Integer'Last+1 elements, issue an error, since such arrays are
	not supported.

From-SVN: r198178

10 files changed, 163 insertions, 58 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 633ac55..9cb2680 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,30 @@
+2013-04-23  Robert Dewar  <dewar@adacore.com>
+
+	* sem_prag.adb (Fix_Error): Rewrite to do more accurate job
+	of getting proper name in the case where pragma comes from
+	aspect.
+	* sem_ch3.adb, sinfo.ads, par-ch6.adb, exp_ch6.adb: Minor reformatting.
+
+2013-04-23  Yannick Moy  <moy@adacore.com>
+
+	* sem_ch6.adb (Process_PPCs): Do not filter postconditions based on
+	applicable policy.
+
+2013-04-23  Thomas Quinot  <quinot@adacore.com>
+
+	* par_sco.adb (Traverse_Aux_Decls): Minor code reorganization.
+
+2013-04-23  Doug Rupp  <rupp@adacore.com>
+
+	* init.c: Move facility macros outside IN_RTS.
+
+2013-04-23  Thomas Quinot  <quinot@adacore.com>
+
+	* freeze.adb (Freeze_Entity): For the case of a bit-packed
+	array time that is known at compile time to have more that
+	Integer'Last+1 elements, issue an error, since such arrays are
+	not supported.
+
 2013-04-23  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_prag.adb (Analyze_Dependency_Clause): Update all calls to
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 11c440b..1be6d72 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -1720,21 +1720,18 @@ package body Exp_Ch6 is
             --  this is harder to verify, and there may be a redundant check.
 
             if (Present (Find_Aspect (E_Actual, Aspect_Predicate))
-              or else Present
-                (Find_Aspect (E_Actual, Aspect_Dynamic_Predicate))
-              or else Present
-                (Find_Aspect (E_Actual, Aspect_Static_Predicate)))
+                  or else
+                Present (Find_Aspect (E_Actual, Aspect_Dynamic_Predicate))
+                  or else
+                Present (Find_Aspect (E_Actual, Aspect_Static_Predicate)))
               and then not Is_Init_Proc (Subp)
             then
-               if Is_Derived_Type (E_Actual)
-                 and then Is_Inherited_Operation_For_Type (Subp, E_Actual)
+               if (Is_Derived_Type (E_Actual)
+                    and then Is_Inherited_Operation_For_Type (Subp, E_Actual))
+                 or else Is_Entity_Name (Actual)
                then
                   Append_To
                     (Post_Call, Make_Predicate_Check (E_Actual, Actual));
-
-               elsif Is_Entity_Name (Actual) then
-                  Append_To
-                    (Post_Call, Make_Predicate_Check (E_Actual, Actual));
                end if;
             end if;
 
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 87bc2c0..95a73a6 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -3913,27 +3913,92 @@ package body Freeze is
                   end if;
                end if;
 
-               --  For bit-packed arrays, check the size
+               --  Specific checks for bit-packed arrays
 
-               if Is_Bit_Packed_Array (E) and then Known_RM_Size (E) then
-                  declare
-                     SizC : constant Node_Id := Size_Clause (E);
+               if Is_Bit_Packed_Array (E) then
 
-                     Discard : Boolean;
-                     pragma Warnings (Off, Discard);
+                  --  Check number of elements for bit packed arrays that come
+                  --  from source and have compile time known ranges. The
+                  --  bit-packed arrays circuitry does not support arrays
+                  --  with more than Integer'Last + 1 elements, and when this
+                  --  restriction is violated, causes incorrect data access.
 
-                  begin
-                     --  It is not clear if it is possible to have no size
-                     --  clause at this stage, but it is not worth worrying
-                     --  about. Post error on the entity name in the size
-                     --  clause if present, else on the type entity itself.
+                  --  For the case where this is not compile time known, a
+                  --  run-time check should be generated???
 
-                     if Present (SizC) then
-                        Check_Size (Name (SizC), E, RM_Size (E), Discard);
-                     else
-                        Check_Size (E, E, RM_Size (E), Discard);
-                     end if;
-                  end;
+                  if Comes_From_Source (E) and then Is_Constrained (E) then
+                     declare
+                        Elmts : Uint;
+                        Index : Node_Id;
+                        Ilen  : Node_Id;
+                        Ityp  : Entity_Id;
+
+                     begin
+                        Elmts := Uint_1;
+                        Index := First_Index (E);
+                        while Present (Index) loop
+                           Ityp := Etype (Index);
+
+                           --  Never generate an error if any index is of a
+                           --  generic type. We will check this in instances.
+
+                           if Is_Generic_Type (Ityp) then
+                              Elmts := Uint_0;
+                              exit;
+                           end if;
+
+                           Ilen :=
+                             Make_Attribute_Reference (Loc,
+                               Prefix         =>
+                                 New_Occurrence_Of (Ityp, Loc),
+                               Attribute_Name => Name_Range_Length);
+                           Analyze_And_Resolve (Ilen);
+
+                           --  No attempt is made to check number of elements
+                           --  if not compile time known.
+
+                           if Nkind (Ilen) /= N_Integer_Literal then
+                              Elmts := Uint_0;
+                              exit;
+                           end if;
+
+                           Elmts := Elmts * Intval (Ilen);
+                           Next_Index (Index);
+                        end loop;
+
+                        if Elmts > Intval (High_Bound
+                                             (Scalar_Range
+                                                (Standard_Integer))) + 1
+                        then
+                           Error_Msg_N
+                             ("bit packed array type may not have "
+                              & "more than Integer''Last+1 elements", E);
+                        end if;
+                     end;
+                  end if;
+
+                  --  Check size
+
+                  if Known_RM_Size (E) then
+                     declare
+                        SizC : constant Node_Id := Size_Clause (E);
+
+                        Discard : Boolean;
+                        pragma Warnings (Off, Discard);
+
+                     begin
+                        --  It is not clear if it is possible to have no size
+                        --  clause at this stage, but it is not worth worrying
+                        --  about. Post error on the entity name in the size
+                        --  clause if present, else on the type entity itself.
+
+                        if Present (SizC) then
+                           Check_Size (Name (SizC), E, RM_Size (E), Discard);
+                        else
+                           Check_Size (E, E, RM_Size (E), Discard);
+                        end if;
+                     end;
+                  end if;
                end if;
 
                --  If any of the index types was an enumeration type with a
diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index 030cb5c..f6f5b2a 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -816,6 +816,10 @@ void (*__gnat_ctrl_c_handler) (void) = 0;
 #define lib_get_invo_handle LIB$GET_INVO_HANDLE
 #endif
 
+/* Masks for facility identification. */
+#define FAC_MASK  		0x0fff0000
+#define DECADA_M_FACILITY	0x00310000
+
 /* Define macro symbols for the VMS conditions that become Ada exceptions.
    It would be better to just include <ssdef.h> */
 
@@ -914,9 +918,6 @@ extern Exception_Code Base_Code_In (Exception_Code);
 /* DEC Ada exceptions are not defined in a header file, so they
    must be declared.  */
 
-#define FAC_MASK  		0x0fff0000
-#define DECADA_M_FACILITY	0x00310000
-
 #define ADA$_ALREADY_OPEN	0x0031a594
 #define ADA$_CONSTRAINT_ERRO	0x00318324
 #define ADA$_DATA_ERROR		0x003192c4
diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb
index 42c2a85..1e96cb2 100644
--- a/gcc/ada/par-ch6.adb
+++ b/gcc/ada/par-ch6.adb
@@ -150,7 +150,7 @@ package body Ch6 is
    --  PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
 
    --  SUBPROGRAM_BODY ::=
-   --    SUBPROGRAM_SPECIFICATION is
+   --    SUBPROGRAM_SPECIFICATION [ASPECT_SPECIFICATIONS] is
    --      DECLARATIVE_PART
    --    begin
    --      HANDLED_SEQUENCE_OF_STATEMENTS
diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb
index f280467..c7aa5c1 100644
--- a/gcc/ada/par_sco.adb
+++ b/gcc/ada/par_sco.adb
@@ -917,7 +917,7 @@ package body Par_SCO is
       From : Nat;
 
       procedure Traverse_Aux_Decls (N : Node_Id);
-      --  Traverse the Aux_Decl_Nodes of compilation unit N
+      --  Traverse the Aux_Decls_Node of compilation unit N
 
       ------------------------
       -- Traverse_Aux_Decls --
@@ -927,8 +927,14 @@ package body Par_SCO is
          ADN : constant Node_Id := Aux_Decls_Node (N);
       begin
          Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
-         Traverse_Declarations_Or_Statements (Declarations   (ADN));
          Traverse_Declarations_Or_Statements (Pragmas_After  (ADN));
+
+         --  Declarations and Actions do not correspond to source constructs,
+         --  they contain only nodes from expansion, so at this point they
+         --  should still be empty:
+
+         pragma Assert (No (Declarations (ADN)));
+         pragma Assert (No (Actions (ADN)));
       end Traverse_Aux_Decls;
 
    --  Start of processing for SCO_Record
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 3bc0e42..55fce93 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3410,7 +3410,7 @@ package body Sem_Ch3 is
 
             if Aliased_Present (N)
               and then (not Is_Entity_Name (E)
-                 or else not Comes_From_Source (E))
+                         or else not Comes_From_Source (E))
             then
                Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
             end if;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index ddd0a90..68f1d41 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -12174,13 +12174,10 @@ package body Sem_Ch6 is
          Prag := First (Declarations (N));
          while Present (Prag) loop
             if Nkind (Prag) = N_Pragma then
-               Check_Applicable_Policy (Prag);
 
-               --  If pragma, capture if postconditions enabled, else ignore
+               --  Capture postcondition pragmas
 
-               if Pragma_Name (Prag) = Name_Postcondition
-                 and then not Is_Ignored (Prag)
-               then
+               if Pragma_Name (Prag) = Name_Postcondition then
                   if Plist = No_List then
                      Plist := Empty_List;
                   end if;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 2deeb8f..8d6a38e 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -827,12 +827,12 @@ package body Sem_Prag is
 
       procedure Fix_Error (Msg : in out String);
       --  This is called prior to issuing an error message. Msg is a string
-      --  that typically contains the substring "pragma". If the current pragma
-      --  comes from an aspect, each such "pragma" substring is replaced with
-      --  the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition
-      --  (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post).
-      --  In addition, if the current pragma results from rewriting another
-      --  pragma, Error_Msg_Name_1 is set to the original pragma name.
+      --  that typically contains the substring "pragma". If the pragma comes
+      --  from an aspect, each such "pragma" substring is replaced with the
+      --  characters "aspect", and Error_Msg_Name_1 is set to the name of the
+      --  aspect (which may be different from the pragma name). If the current
+      --  pragma results from rewriting another pragma, then Error_Msg_Name_1
+      --  is set to the original pragma name.
 
       procedure Gather_Associations
         (Names : Name_List;
@@ -2864,24 +2864,33 @@ package body Sem_Prag is
       ---------------
 
       procedure Fix_Error (Msg : in out String) is
-         Orig : constant Node_Id := Original_Node (N);
-
       begin
+         --  If we have a rewriting of another pragma, go to that pragma
+
+         if Is_Rewrite_Substitution (N)
+           and then Nkind (Original_Node (N)) = N_Pragma
+         then
+            Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
+         end if;
+
+         --  Case where pragma comes from an aspect specification
+
          if From_Aspect_Specification (N) then
+
+            --  Change appearence of "pragma" in message to "aspect"
+
             for J in Msg'First .. Msg'Last - 5 loop
                if Msg (J .. J + 5) = "pragma" then
                   Msg (J .. J + 5) := "aspect";
                end if;
             end loop;
 
-            if Error_Msg_Name_1 = Name_Precondition then
-               Error_Msg_Name_1 := Name_Pre;
-            elsif Error_Msg_Name_1 = Name_Postcondition then
-               Error_Msg_Name_1 := Name_Post;
-            end if;
+            --  Get name from corresponding aspect
 
-         elsif Orig /= N and then Nkind (Orig) = N_Pragma then
-            Error_Msg_Name_1 := Pragma_Name (Orig);
+            if Present (Corresponding_Aspect (N)) then
+               Error_Msg_Name_1 :=
+                 Chars (Identifier (Corresponding_Aspect (N)));
+            end if;
          end if;
       end Fix_Error;
 
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 9afeeff..90de0b0 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -1327,8 +1327,8 @@ package Sinfo is
    --    an Assertion_Policy pragma), then Is_Ignored is set if assertions are
    --    ignored because of the absence of a -gnata switch. For any other
    --    aspects or pragmas, the flag is off. If this flag is set, the
-   --    aspect/pragma is fully analyzed and checked for other
-   --    syntactic/semantic errors, but it does not have any semantic effect.
+   --    aspect/pragma is fully analyzed and checked for other syntactic
+   --    and semantic errors, but it does not have any semantic effect.
 
    --  Is_In_Discriminant_Check (Flag11-Sem)
    --    This flag is present in a selected component, and is used to indicate
@@ -2145,7 +2145,10 @@ package Sinfo is
       --  where the interesting allowed cases (which do not fit the syntax of
       --  the first alternative above) are
 
-      --  ASPECT_MARK => Pre'Class | Post'Class | Type_Invariant'Class
+      --  ASPECT_MARK => Pre'Class |
+      --                 Post'Class |
+      --                 Type_Invariant'Class |
+      --                 Invariant'Class
 
       --  We allow this special usage in all Ada modes, but it would be a
       --  pain to allow these aspects to pervade the pragma syntax, and the
@@ -4728,7 +4731,7 @@ package Sinfo is
       --------------------------
 
       --  SUBPROGRAM_BODY ::=
-      --    SUBPROGRAM_SPECIFICATION is
+      --    SUBPROGRAM_SPECIFICATION [ASPECT_SPECIFICATIONS] is
       --      DECLARATIVE_PART
       --    begin
       --      HANDLED_SEQUENCE_OF_STATEMENTS