+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.
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)
-- --
-- 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- --
-- 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
-- --
------------------------------------------------------------------------------
+-- 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;
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
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;
others => <>),
Occurrence => <>));
-- Allocate and initialize a machine occurrence
+
end System.Exceptions.Machine;
-- --
------------------------------------------------------------------------------
+-- 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;
others => 0),
Occurrence => <>));
-- Allocate and initialize a machine occurrence
+
end System.Exceptions.Machine;
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;
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
---------------------
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;
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
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;
-- 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)),
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
projects / thirdparty / gcc.git / commitdiff
