2012-12-05 Ed Schonberg <schonberg@adacore.com>

	* aspects.ads, aspects.adb: Add aspect Relative_Deadline.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Process aspect
	Relative_Deadline, and introduce the corresponding pragma within
	the task definition of the task type to which it applies.
	(Check_Aspect_At_Freeze_Point): Expression in a Relative_Deadline
	aspect is of type Time_Span.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@194214 138bc75d-0d04-0410-961f-82ee72b054a4

4 files changed, 63 insertions, 1 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 89030d9d584..7b4634c8b5d 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2012-12-05  Ed Schonberg  <schonberg@adacore.com>
+
+	* aspects.ads, aspects.adb: Add aspect Relative_Deadline.
+	* sem_ch13.adb (Analyze_Aspect_Specifications): Process aspect
+	Relative_Deadline, and introduce the corresponding pragma within
+	the task definition of the task type to which it applies.
+	(Check_Aspect_At_Freeze_Point): Expression in a Relative_Deadline
+	aspect is of type Time_Span.
+
 2012-12-05  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_prag.adb (Check_Loop_Invariant_Variant_Placement): When pragma
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index e3e75717580..dcc73144709 100644
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -304,6 +304,7 @@ package body Aspects is
     Aspect_Remote_Call_Interface        => Aspect_Remote_Call_Interface,
     Aspect_Remote_Types                 => Aspect_Remote_Types,
     Aspect_Read                         => Aspect_Read,
+    Aspect_Relative_Deadline            => Aspect_Relative_Deadline,
     Aspect_Scalar_Storage_Order         => Aspect_Scalar_Storage_Order,
     Aspect_Shared                       => Aspect_Atomic,
     Aspect_Shared_Passive               => Aspect_Shared_Passive,
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index d896de8bc3e..7d64feee66a 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -109,6 +109,7 @@ package Aspects is
       Aspect_Predicate,                     -- GNAT
       Aspect_Priority,
       Aspect_Read,
+      Aspect_Relative_Deadline,
       Aspect_Scalar_Storage_Order,          -- GNAT
       Aspect_Simple_Storage_Pool,           -- GNAT
       Aspect_Size,
@@ -339,6 +340,7 @@ package Aspects is
                         Aspect_Predicate               => Expression,
                         Aspect_Priority                => Expression,
                         Aspect_Read                    => Name,
+                        Aspect_Relative_Deadline       => Expression,
                         Aspect_Scalar_Storage_Order    => Expression,
                         Aspect_Simple_Storage_Pool     => Name,
                         Aspect_Size                    => Expression,
@@ -431,6 +433,7 @@ package Aspects is
      Aspect_Pure_12                      => Name_Pure_12,
      Aspect_Pure_Function                => Name_Pure_Function,
      Aspect_Read                         => Name_Read,
+     Aspect_Relative_Deadline            => Name_Relative_Deadline,
      Aspect_Remote_Access_Type           => Name_Remote_Access_Type,
      Aspect_Remote_Call_Interface        => Name_Remote_Call_Interface,
      Aspect_Remote_Types                 => Name_Remote_Types,
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 887b0792e78..eee75d52a1e 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1433,6 +1433,48 @@ package body Sem_Ch13 is
 
                   Delay_Required := False;
 
+               --  Case 2d : Aspects that correspond to a pragma with one
+               --  argument.
+
+               when Aspect_Relative_Deadline     =>
+                  Aitem :=
+                    Make_Pragma (Loc,
+                      Pragma_Argument_Associations =>
+                        New_List (
+                          Make_Pragma_Argument_Association (Loc,
+                             Expression => Relocate_Node (Expr))),
+                      Pragma_Identifier            =>
+                        Make_Identifier (Sloc (Id), Name_Relative_Deadline));
+
+                  --  If the aspect applies to a task, the corresponding pragma
+                  --  must appear within its declarations, not after.
+
+                  if Nkind (N) = N_Task_Type_Declaration then
+                     declare
+                        Def : Node_Id;
+                        V   : List_Id;
+
+                     begin
+                        if No (Task_Definition (N)) then
+                           Set_Task_Definition (N,
+                             Make_Task_Definition (Loc,
+                                Visible_Declarations => New_List,
+                                End_Label => Empty));
+                        end if;
+
+                        Def := Task_Definition (N);
+                        V  := Visible_Declarations (Def);
+                        if not Is_Empty_List (V) then
+                           Insert_Before (First (V), Aitem);
+
+                        else
+                           Set_Visible_Declarations (Def, New_List (Aitem));
+                        end if;
+
+                        goto Continue;
+                     end;
+                  end if;
+
                --  Case 3 : Aspects that don't correspond to pragma/attribute
                --  definition clause.
 
@@ -5186,7 +5228,11 @@ package body Sem_Ch13 is
                end if;
 
                Exp := New_Copy_Tree (Arg2);
-               Loc := Sloc (Exp);
+
+               --  Preserve sloc of original pragma Invariant (this is required
+               --  by Par_SCO).
+
+               Loc := Sloc (Ritem);
 
                --  We need to replace any occurrences of the name of the type
                --  with references to the object, converted to type'Class in
@@ -6796,6 +6842,9 @@ package body Sem_Ch13 is
          when Aspect_Priority | Aspect_Interrupt_Priority =>
             T := Standard_Integer;
 
+         when Aspect_Relative_Deadline =>
+            T := RTE (RE_Time_Span);
+
          when Aspect_Small =>
             T := Universal_Real;