[Ada] Implement pragma Max_Entry_Queue_Depth

This patch implements AI12-0164-1 for the aspect/pragma Max_Entry_Queue_Depth.
Previously, the GNAT specific pragma Max_Queue_Length fulfilled this role, but
was not named to match the standard and thus was insufficent.

------------
-- Source --
------------

--  pass.ads

with System;
package Pass is

   SOMETHING : constant Integer := 5;
   Variable : Boolean := False;

   protected type Protected_Example is

      entry A (Item : Integer)
         with Max_Entry_Queue_Depth => 2;            --  OK

      entry B (Item : Integer);
      pragma Max_Entry_Queue_Depth (SOMETHING);      --  OK

      entry C (Item : Integer);                      --  OK

      entry D (Item : Integer)
         with Max_Entry_Queue_Depth => 4;            --  OK

      entry D (Item : Integer; Item_B : Integer)
         with Max_Entry_Queue_Depth => Float'Digits; --  OK

      entry E (Item : Integer);
      pragma Max_Entry_Queue_Depth (SOMETHING * 2);  --  OK

      entry E (Item : Integer; Item_B : Integer);
      pragma Max_Entry_Queue_Depth (11);             --  OK

      entry F (Item : Integer; Item_B : Integer);
      pragma Pre (Variable = True);
      pragma Max_Entry_Queue_Depth (11);             --  OK

      entry G (Item : Integer; Item_B : Integer)
         with Pre => (Variable = True),
              Max_Entry_Queue_Depth => 11;           --  OK

   private
      Data : Boolean := True;
   end Protected_Example;

   Prot_Ex  : Protected_Example;

end Pass;

--  fail.ads

package Fail is

   --  Not near entry

   pragma Max_Entry_Queue_Depth (40);                                --  ERROR

   --  Task type

   task type Task_Example is

      entry Insert (Item : in Integer)
         with Max_Entry_Queue_Depth => 10;                           --  ERROR

      -- Entry family in task type

      entry A (Positive) (Item : in Integer)
         with Max_Entry_Queue_Depth => 10;                           --  ERROR

   end Task_Example;

   Task_Ex : Task_Example;

   --  Aspect applied to protected type

   protected type Protected_Failure_0
      with Max_Entry_Queue_Depth => 50 is                            --  ERROR

      entry A (Item : Integer);
   private
      Data : Integer := 0;
   end Protected_Failure_0;

   Protected_Failure_0_Ex : Protected_Failure_0;

   protected type Protected_Failure is
      pragma Max_Entry_Queue_Depth (10);                             --  ERROR

      --  Duplicates

      entry A (Item : Integer)
         with Max_Entry_Queue_Depth => 10;                           --  OK
      pragma Max_Entry_Queue_Depth (4);                              --  ERROR

      entry B (Item : Integer);
      pragma Max_Entry_Queue_Depth (40);                             --  OK
      pragma Max_Entry_Queue_Depth (4);                              --  ERROR

      entry C (Item : Integer)
         with Max_Entry_Queue_Depth => 10,                           --  OK
              Max_Entry_Queue_Depth => 40;                           --  ERROR

      -- Duplicates with the same value

      entry AA (Item : Integer)
         with Max_Entry_Queue_Depth => 10;                           --  OK
      pragma Max_Entry_Queue_Depth (10);                             --  ERROR

      entry BB (Item : Integer);
      pragma Max_Entry_Queue_Depth (40);                             --  OK
      pragma Max_Entry_Queue_Depth (40);                             --  ERROR

      entry CC (Item : Integer)
         with Max_Entry_Queue_Depth => 10,                           --  OK
              Max_Entry_Queue_Depth => 10;                           --  ERROR

      --  On subprogram

      procedure D (Item : Integer)
         with Max_Entry_Queue_Depth => 10;                           --  ERROR

      procedure E (Item : Integer);
      pragma Max_Entry_Queue_Depth (4);                              --  ERROR

      function F (Item : Integer) return Integer
         with Max_Entry_Queue_Depth => 10;                           --  ERROR

      function G (Item : Integer) return Integer;
      pragma Max_Entry_Queue_Depth (4);                              --  ERROR

      --  Bad parameters

      entry H (Item : Integer)
         with Max_Entry_Queue_Depth => 0;                            --  ERROR

      entry I (Item : Integer)
         with Max_Entry_Queue_Depth => -1;                           --  ERROR

      entry J (Item : Integer)
         with Max_Entry_Queue_Depth => 16#FFFF_FFFF_FFFF_FFFF_FFFF#; --  ERROR

      entry K (Item : Integer)
         with Max_Entry_Queue_Depth => False;                        --  ERROR

      entry L (Item : Integer)
         with Max_Entry_Queue_Depth => "JUNK";                       --  ERROR

      entry M (Item : Integer)
         with Max_Entry_Queue_Depth => 1.0;                          --  ERROR

      entry N (Item : Integer)
         with Max_Entry_Queue_Depth => Long_Integer'(3);             --  ERROR

      -- Entry family

      entry O (Boolean) (Item : Integer)
         with Max_Entry_Queue_Depth => 5;                            --  ERROR

   private
      Data : Integer := 0;
   end Protected_Failure;

   I : Positive := 1;

   Protected_Failure_Ex : Protected_Failure;

end Fail;

--  dtest.adb

with Ada.Text_IO; use Ada.Text_IO;

procedure Dtest is
   protected Prot is
      entry Wait;
        pragma Max_Entry_Queue_Depth (2);
      procedure Wakeup;
   private
      Barrier : Boolean := False;
   end Prot;

   protected body Prot is
      entry Wait when Barrier is
      begin
         null;
      end Wait;

      procedure Wakeup is
      begin
         Barrier := True;
      end Wakeup;
   end Prot;

   task type T;

   task body T is
   begin
      Put_Line ("Waiting...");
      Prot.Wait;
   exception
      when others =>
         Put_Line ("Got exception");
   end T;

   T1, T2 : T;
begin
   delay 0.1;

   Prot.Wait;
   Put_Line ("Done");
exception
   when others =>
      Put_Line ("Main got exception");
      Prot.Wakeup;
end Dtest;

----------------------------
-- Compilation and output --
----------------------------

& gcc -c -g -gnatDG pass.ads
& gcc -c -g fail.ads
& grep -c "(2, 5, 0, 4, 6, 10, 11, 11, 11)" pass.ads.dg
& gnatmake -g -q dtest
fail.ads:5:04: pragma "Max_Queue_Length" must apply to a protected entry
fail.ads:12:15: aspect "Max_Queue_Length" cannot apply to task entries
fail.ads:17:15: aspect "Max_Queue_Length" cannot apply to task entries
fail.ads:26:12: aspect "Max_Queue_Length" must apply to a protected entry
fail.ads:36:07: pragma "Max_Queue_Length" must apply to a protected entry
fail.ads:42:07: pragma "Max_Queue_Length" duplicates aspect declared at line 41
fail.ads:46:07: pragma "Max_Queue_Length" duplicates pragma declared at line 45
fail.ads:50:15: aspect "Max_Queue_Length" for "C" previously given at line 49
fail.ads:56:07: pragma "Max_Queue_Length" duplicates aspect declared at line 55
fail.ads:60:07: pragma "Max_Queue_Length" duplicates pragma declared at line 59
fail.ads:64:15: aspect "Max_Queue_Length" for "CC" previously given at line 63
fail.ads:69:15: aspect "Max_Queue_Length" must apply to a protected entry
fail.ads:72:07: pragma "Max_Queue_Length" must apply to a protected entry
fail.ads:75:15: aspect "Max_Queue_Length" must apply to a protected entry
fail.ads:78:07: pragma "Max_Queue_Length" must apply to a protected entry
fail.ads:83:35: entity for aspect "Max_Queue_Length" must be positive
fail.ads:86:35: entity for aspect "Max_Queue_Length" must be positive
fail.ads:89:35: entity for aspect "Max_Queue_Length" out of range of Integer
fail.ads:92:35: expected an integer type
fail.ads:92:35: found type "Standard.Boolean"
fail.ads:95:35: expected an integer type
fail.ads:95:35: found a string type
fail.ads:98:35: expected an integer type
fail.ads:98:35: found type universal real

2018-05-30  Justin Squirek  <squirek@adacore.com>

gcc/ada/

	* aspects.adb, aspects.ads: Register new aspect.
	* par-prag.adb (Prag): Register new pragma.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Add processing for new
	aspect similar to Aspect_Max_Queue_Length.
	* sem_prag.adb, sem_prag.ads (Analyze_Pragma): Register new pragma and
	set it to use the same processing as Pragma_Max_Queue_Length.
	* snames.ads-tmpl: Move definition of Name_Max_Entry_Queue_Depth so
	that it can be processed as a pragma in addition to a restriction and
	add an entry for the pragma itself.

From-SVN: r260945

8 files changed, 47 insertions, 3 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index f9a9eca..b839b7a 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,15 @@
+2018-05-30  Justin Squirek  <squirek@adacore.com>
+
+	* aspects.adb, aspects.ads: Register new aspect.
+	* par-prag.adb (Prag): Register new pragma.
+	* sem_ch13.adb (Analyze_Aspect_Specifications): Add processing for new
+	aspect similar to Aspect_Max_Queue_Length.
+	* sem_prag.adb, sem_prag.ads (Analyze_Pragma): Register new pragma and
+	set it to use the same processing as Pragma_Max_Queue_Length.
+	* snames.ads-tmpl: Move definition of Name_Max_Entry_Queue_Depth so
+	that it can be processed as a pragma in addition to a restriction and
+	add an entry for the pragma itself.
+
 2018-05-30  Ed Schonberg  <schonberg@adacore.com>
 
 	* freeze.adb (Freeze_Object_Declaration): A pragma Thread_Local_Storage
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index d9f7259..61744cd 100644
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -568,6 +568,7 @@ package body Aspects is
     Aspect_Linker_Section               => Aspect_Linker_Section,
     Aspect_Lock_Free                    => Aspect_Lock_Free,
     Aspect_Machine_Radix                => Aspect_Machine_Radix,
+    Aspect_Max_Entry_Queue_Depth        => Aspect_Max_Entry_Queue_Depth,
     Aspect_Max_Queue_Length             => Aspect_Max_Queue_Length,
     Aspect_No_Elaboration_Code_All      => Aspect_No_Elaboration_Code_All,
     Aspect_No_Inline                    => Aspect_No_Inline,
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 16dcab8..3038020 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -116,6 +116,7 @@ package Aspects is
       Aspect_Link_Name,
       Aspect_Linker_Section,                -- GNAT
       Aspect_Machine_Radix,
+      Aspect_Max_Entry_Queue_Depth,
       Aspect_Max_Queue_Length,              -- GNAT
       Aspect_Object_Size,                   -- GNAT
       Aspect_Obsolescent,                   -- GNAT
@@ -250,6 +251,7 @@ package Aspects is
       Aspect_Inline_Always              => True,
       Aspect_Invariant                  => True,
       Aspect_Lock_Free                  => True,
+      Aspect_Max_Entry_Queue_Depth      => True,
       Aspect_Max_Queue_Length           => True,
       Aspect_Object_Size                => True,
       Aspect_Persistent_BSS             => True,
@@ -358,6 +360,7 @@ package Aspects is
       Aspect_Link_Name                  => Expression,
       Aspect_Linker_Section             => Expression,
       Aspect_Machine_Radix              => Expression,
+      Aspect_Max_Entry_Queue_Depth      => Expression,
       Aspect_Max_Queue_Length           => Expression,
       Aspect_Object_Size                => Expression,
       Aspect_Obsolescent                => Optional_Expression,
@@ -467,6 +470,7 @@ package Aspects is
       Aspect_Linker_Section               => Name_Linker_Section,
       Aspect_Lock_Free                    => Name_Lock_Free,
       Aspect_Machine_Radix                => Name_Machine_Radix,
+      Aspect_Max_Entry_Queue_Depth        => Name_Max_Entry_Queue_Depth,
       Aspect_Max_Queue_Length             => Name_Max_Queue_Length,
       Aspect_No_Elaboration_Code_All      => Name_No_Elaboration_Code_All,
       Aspect_No_Inline                    => Name_No_Inline,
@@ -743,6 +747,7 @@ package Aspects is
       Aspect_Import                       => Never_Delay,
       Aspect_Initial_Condition            => Never_Delay,
       Aspect_Initializes                  => Never_Delay,
+      Aspect_Max_Entry_Queue_Depth        => Never_Delay,
       Aspect_Max_Queue_Length             => Never_Delay,
       Aspect_No_Elaboration_Code_All      => Never_Delay,
       Aspect_No_Tagged_Streams            => Never_Delay,
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index 047ca92..8bd091f 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -1410,6 +1410,7 @@ begin
          | Pragma_Machine_Attribute
          | Pragma_Main
          | Pragma_Main_Storage
+         | Pragma_Max_Entry_Queue_Depth
          | Pragma_Max_Queue_Length
          | Pragma_Memory_Size
          | Pragma_No_Body
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index d287f26..145f637 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -3013,6 +3013,19 @@ package body Sem_Ch13 is
                   goto Continue;
                end Initializes;
 
+               --  Max_Entry_Queue_Depth
+
+               when Aspect_Max_Entry_Queue_Depth =>
+                  Make_Aitem_Pragma
+                    (Pragma_Argument_Associations => New_List (
+                       Make_Pragma_Argument_Association (Loc,
+                         Expression => Relocate_Node (Expr))),
+                     Pragma_Name => Name_Max_Entry_Queue_Depth);
+
+                  Decorate (Aspect, Aitem);
+                  Insert_Pragma (Aitem);
+                  goto Continue;
+
                --  Max_Queue_Length
 
                when Aspect_Max_Queue_Length =>
@@ -9507,6 +9520,7 @@ package body Sem_Ch13 is
             | Aspect_Implicit_Dereference
             | Aspect_Initial_Condition
             | Aspect_Initializes
+            | Aspect_Max_Entry_Queue_Depth
             | Aspect_Max_Queue_Length
             | Aspect_Obsolescent
             | Aspect_Part_Of
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 4547ef1..abab195 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -18759,14 +18759,22 @@ package body Sem_Prag is
 
          --  pragma Max_Queue_Length (static_integer_EXPRESSION);
 
-         when Pragma_Max_Queue_Length => Max_Queue_Length : declare
+         --  This processing is shared by Pragma_Max_Entry_Queue_Depth
+
+         when Pragma_Max_Queue_Length
+            | Pragma_Max_Entry_Queue_Depth
+         =>
+         Max_Queue_Length : declare
             Arg        : Node_Id;
             Entry_Decl : Node_Id;
             Entry_Id   : Entity_Id;
             Val        : Uint;
 
          begin
-            GNAT_Pragma;
+            if Prag_Id = Pragma_Max_Queue_Length then
+               GNAT_Pragma;
+            end if;
+
             Check_Arg_Count (1);
 
             Entry_Decl :=
@@ -30174,6 +30182,7 @@ package body Sem_Prag is
       Pragma_Machine_Attribute              => -1,
       Pragma_Main                           => -1,
       Pragma_Main_Storage                   => -1,
+      Pragma_Max_Entry_Queue_Depth          =>  0,
       Pragma_Max_Queue_Length               =>  0,
       Pragma_Memory_Size                    =>  0,
       Pragma_No_Return                      =>  0,
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index 56cff0f..7e06142 100644
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -397,6 +397,7 @@ package Sem_Prag is
    --    Extensions_Visible
    --    Global
    --    Initializes
+   --    Max_Entry_Queue_Depth
    --    Max_Queue_Length
    --    Post
    --    Post_Class
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 25d6fca..baa4101 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -588,6 +588,7 @@ package Snames is
    Name_Machine_Attribute              : constant Name_Id := N + $; -- GNAT
    Name_Main                           : constant Name_Id := N + $; -- GNAT
    Name_Main_Storage                   : constant Name_Id := N + $; -- GNAT
+   Name_Max_Entry_Queue_Depth          : constant Name_Id := N + $; -- Ada 12
    Name_Max_Queue_Length               : constant Name_Id := N + $; -- GNAT
    Name_Memory_Size                    : constant Name_Id := N + $; -- Ada 83
    Name_No_Body                        : constant Name_Id := N + $; -- GNAT
@@ -776,7 +777,6 @@ package Snames is
    Name_Link_Name                      : constant Name_Id := N + $;
    Name_Low_Order_First                : constant Name_Id := N + $;
    Name_Lowercase                      : constant Name_Id := N + $;
-   Name_Max_Entry_Queue_Depth          : constant Name_Id := N + $;
    Name_Max_Entry_Queue_Length         : constant Name_Id := N + $;
    Name_Max_Size                       : constant Name_Id := N + $;
    Name_Mechanism                      : constant Name_Id := N + $;
@@ -1962,6 +1962,7 @@ package Snames is
       Pragma_Machine_Attribute,
       Pragma_Main,
       Pragma_Main_Storage,
+      Pragma_Max_Entry_Queue_Depth,
       Pragma_Max_Queue_Length,
       Pragma_Memory_Size,
       Pragma_No_Body,