sem_attr.adb (Analyze_Attribute, [...]): Allow Loop_Entry in Assert,…

sem_attr.adb (Analyze_Attribute, [...]): Allow Loop_Entry in Assert, Assert_And_Cut, and Assume pragmas.

2014-01-20  Robert Dewar  <dewar@adacore.com>

	* sem_attr.adb (Analyze_Attribute, case Loop_Entry): Allow
	Loop_Entry in Assert, Assert_And_Cut, and Assume pragmas.
	* sem_prag.adb (Analyze_Pragma, case Assert[_And_Cut], Assume):
	Allow Loop_Entry to be used in these pragmas if they appear in
	an appropriate context.
	(Placement_Error): Specialize error
	message for pragma Assert[_And_Cut] or pragma Assume containing
	Loop_Entry attribute.
	* a-exexpr-gcc.adb, sinput.adb: Minor reformatting.
	* s-excmac-arm.ads, s-except.ads, s-excmac-gcc.ads: Minor reformatting
	and code clean ups.

From-SVN: r206818

gcc/ada/ChangeLog

 2014-01-20  Robert Dewar  <dewar@adacore.com>
 
+	* sem_attr.adb (Analyze_Attribute, case Loop_Entry): Allow
+	Loop_Entry in Assert, Assert_And_Cut, and Assume pragmas.
+	* sem_prag.adb (Analyze_Pragma, case Assert[_And_Cut], Assume):
+	Allow Loop_Entry to be used in these pragmas if they appear in
+	an appropriate context.
+	(Placement_Error): Specialize error
+	message for pragma Assert[_And_Cut] or pragma Assume containing
+	Loop_Entry attribute.
+	* a-exexpr-gcc.adb, sinput.adb: Minor reformatting.
+	* s-excmac-arm.ads, s-except.ads, s-excmac-gcc.ads: Minor reformatting
+	and code clean ups.
+
+2014-01-20  Robert Dewar  <dewar@adacore.com>
+
 	* gnat1drv.adb: Minor comment update.
 
 2014-01-20  Tristan Gingold  <gingold@adacore.com>

gcc/ada/a-exexpr-gcc.adb

@@ -34,7 +34,7 @@
 with Ada.Unchecked_Conversion;
 with Ada.Unchecked_Deallocation;
 
-with System.Storage_Elements;  use System.Storage_Elements;
+with System.Storage_Elements;   use System.Storage_Elements;
 with System.Exceptions.Machine; use System.Exceptions.Machine;
 
 separate (Ada.Exceptions)

gcc/ada/s-except.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2006-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2006-2013, 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- --
@@ -37,7 +37,7 @@ package System.Exceptions is
    --  To let Ada.Exceptions "with" us and let us "with" Standard_Library
 
    ZCX_By_Default : constant Boolean;
-   --  Visible copy to allow Ada.Exceptions to know the exception model.
+   --  Visible copy to allow Ada.Exceptions to know the exception model
 
 private
 

gcc/ada/s-excmac-arm.ads

@@ -29,6 +29,10 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+--  Declaration of the machine exception and some associated facilities. The
+--  machine exception is the object that is propagated by low level routines
+--  and that contains the Ada exception occurrence.
+
 --  This is the version using the ARM EHABI mechanism
 
 with Ada.Unchecked_Conversion;
@@ -106,8 +110,8 @@ package System.Exceptions.Machine is
    end record;
 
    type Barrier_Cache_Type is record
-      Sp          : uint32_t;
-      Bitpattern  : uint32_t_array (0 .. 4);
+      Sp         : uint32_t;
+      Bitpattern : uint32_t_array (0 .. 4);
    end record;
 
    type Cleanup_Cache_Type is record
@@ -122,8 +126,8 @@ package System.Exceptions.Machine is
    end record;
 
    type Unwind_Control_Block is record
-      Class    : Exception_Class;
-      Cleanup  : System.Address;
+      Class   : Exception_Class;
+      Cleanup : System.Address;
 
       --  Caches
       Unwinder_Cache : Unwinder_Cache_Type;
@@ -178,4 +182,5 @@ package System.Exceptions.Machine is
                          others => <>),
           Occurrence => <>));
    --  Allocate and initialize a machine occurrence
+
 end System.Exceptions.Machine;

gcc/ada/s-excmac-gcc.ads

@@ -29,6 +29,10 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+--  Declaration of the machine exception and some associated facilities. The
+--  machine exception is the object that is propagated by low level routines
+--  and that contains the Ada exception occurrence.
+
 --  This is the version using the GCC EH mechanism
 
 with Ada.Unchecked_Conversion;
@@ -183,4 +187,5 @@ package System.Exceptions.Machine is
                         others  => 0),
          Occurrence => <>));
    --  Allocate and initialize a machine occurrence
+
 end System.Exceptions.Machine;

gcc/ada/sem_attr.adb

@@ -3903,13 +3903,17 @@ package body Sem_Attr is
          Stmt := Attr;
          while Present (Stmt) loop
 
-            --  Locate the enclosing Loop_Invariant / Loop_Variant pragma
+            --  Locate the corresponding enclosing pragma. Note that in the
+            --  case of Assert[And_Cut] and Assume, we have already checked
+            --  that the pragma appears in an appropriate loop location.
 
             if Nkind (Original_Node (Stmt)) = N_Pragma
-              and then
-                Nam_In (Pragma_Name (Original_Node (Stmt)),
-                        Name_Loop_Invariant,
-                        Name_Loop_Variant)
+              and then Nam_In (Pragma_Name (Original_Node (Stmt)),
+                               Name_Loop_Invariant,
+                               Name_Loop_Variant,
+                               Name_Assert,
+                               Name_Assert_And_Cut,
+                               Name_Assume)
             then
                In_Loop_Assertion := True;
 
@@ -3941,12 +3945,14 @@ package body Sem_Attr is
             Stmt := Parent (Stmt);
          end loop;
 
-         --  Loop_Entry must appear within a Loop_Assertion pragma
+            --  Loop_Entry must appear within a Loop_Assertion pragma (Assert,
+            --  Assert_And_Cut, Assume count as loop assertion pragmas for this
+            --  purpose if they appear in an appropriate location in a loop,
+            --  which was already checked by the top level pragma circuit).
 
          if not In_Loop_Assertion then
             Error_Attr
-              ("attribute % must appear within pragma Loop_Variant or " &
-               "Loop_Invariant", N);
+              ("attribute % must appear within appropriate pragma", N);
          end if;
 
          --  A Loop_Entry that applies to a given loop statement shall not

gcc/ada/sem_prag.adb

@@ -4074,14 +4074,22 @@ package body Sem_Prag is
          ---------------------
 
          procedure Placement_Error (Constr : Node_Id) is
+            LA : constant String := " with Loop_Entry";
          begin
+            if Prag_Id = Pragma_Assert then
+               Error_Msg_String (1 .. LA'Length) := LA;
+               Error_Msg_Strlen := LA'Length;
+            else
+               Error_Msg_Strlen := 0;
+            end if;
+
             if Nkind (Constr) = N_Pragma then
                Error_Pragma
-                 ("pragma % must appear immediately within the statements "
+                 ("pragma %~ must appear immediately within the statements "
                   & "of a loop");
             else
                Error_Pragma_Arg
-                 ("block containing pragma % must appear immediately within "
+                 ("block containing pragma %~ must appear immediately within "
                   & "the statements of a loop", Constr);
             end if;
          end Placement_Error;
@@ -9915,6 +9923,48 @@ package body Sem_Prag is
             Expr : Node_Id;
             Newa : List_Id;
 
+            Has_Loop_Entry : Boolean;
+            --  Set True by
+
+            function Contains_Loop_Entry return Boolean;
+            --  Tests if Expr contains a Loop_Entry attribute reference
+
+            -------------------------
+            -- Contains_Loop_Entry --
+            -------------------------
+
+            function Contains_Loop_Entry return Boolean is
+               function Process (N : Node_Id) return Traverse_Result;
+               --  Process function for traversal to look for Loop_Entry
+
+               -------------
+               -- Process --
+               -------------
+
+               function Process (N : Node_Id) return Traverse_Result is
+               begin
+                  if Nkind (N) = N_Attribute_Reference
+                    and then Attribute_Name (N) = Name_Loop_Entry
+                  then
+                     Has_Loop_Entry := True;
+                     return Abandon;
+                  else
+                     return OK;
+                  end if;
+               end Process;
+
+               procedure Traverse is new Traverse_Proc (Process);
+
+            --  Start of processing for Contains_Loop_Entry
+
+            begin
+               Has_Loop_Entry := False;
+               Traverse (Expr);
+               return Has_Loop_Entry;
+            end Contains_Loop_Entry;
+
+         --  Start of processing for Assert
+
          begin
             --  Assert is an Ada 2005 RM-defined pragma
 
@@ -9931,11 +9981,14 @@ package body Sem_Prag is
             Check_At_Most_N_Arguments (2);
             Check_Arg_Order ((Name_Check, Name_Message));
             Check_Optional_Identifier (Arg1, Name_Check);
+            Expr := Get_Pragma_Arg (Arg1);
 
-            --  Special processing for Loop_Invariant
-
-            if Prag_Id = Pragma_Loop_Invariant then
+            --  Special processing for Loop_Invariant or for other cases if
+            --  a Loop_Entry attribute is present.
 
+            if Prag_Id = Pragma_Loop_Invariant
+              or else Contains_Loop_Entry
+            then
                --  Check restricted placement, must be within a loop
 
                Check_Loop_Pragma_Placement;
@@ -9959,7 +10012,6 @@ package body Sem_Prag is
             --  Assume, or Assert_And_Cut pragma can be retrieved from the
             --  pragma kind of Original_Node(N).
 
-            Expr := Get_Pragma_Arg (Arg1);
             Newa := New_List (
               Make_Pragma_Argument_Association (Loc,
                 Expression => Make_Identifier (Loc, Pname)),

gcc/ada/sinput.adb

@@ -771,6 +771,7 @@ package body Sinput is
 
       function Process (N : Node_Id) return Traverse_Result is
          Orig : constant Node_Id := Original_Node (N);
+
       begin
          if Sloc (Orig) < Min then
             if Sloc (Orig) > No_Location then