[Ada] Implement pragma Max_Entry_Queue_Length

This patch implements AI12-0164-1 for the aspect/pragma
Max_Entry_Queue_Length.  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_Length => 2;            --  OK

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

      entry C (Item : Integer);                      --  OK

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

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

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

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

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

      entry G (Item : Integer; Item_B : Integer)
         with Pre => (Variable = True),
              Max_Entry_Queue_Length => 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_Length (40);                                --  ERROR

   --  Task type

   task type Task_Example is

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

      -- Entry family in task type

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

   end Task_Example;

   Task_Ex : Task_Example;

   --  Aspect applied to protected type

   protected type Protected_Failure_0
      with Max_Entry_Queue_Length => 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_Length (10);                             --  ERROR

      --  Duplicates

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

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

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

      -- Duplicates with the same value

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

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

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

      --  On subprogram

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

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

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

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

      --  Bad parameters

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

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

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

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

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

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

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

      -- Entry family

      entry O (Boolean) (Item : Integer)
         with Max_Entry_Queue_Length => 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_Length (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_Entry_Queue_Length" must apply to a protected entry
fail.ads:12:15: aspect "Max_Entry_Queue_Length" cannot apply to task entries
fail.ads:17:15: aspect "Max_Entry_Queue_Length" cannot apply to task entries
fail.ads:26:12: aspect "Max_Entry_Queue_Length" must apply to a protected entry
fail.ads:36:07: pragma "Max_Entry_Queue_Length" must apply to a protected entry
fail.ads:42:07: pragma "Max_Entry_Queue_Length" duplicates aspect declared at
line 41
fail.ads:46:07: pragma "Max_Entry_Queue_Length" duplicates pragma declared at
line 45
fail.ads:50:15: aspect "Max_Entry_Queue_Length" for "C" previously given at
line 49
fail.ads:56:07: pragma "Max_Entry_Queue_Length" duplicates aspect declared at
line 55
fail.ads:60:07: pragma "Max_Entry_Queue_Length" duplicates pragma declared at
line 59
fail.ads:64:15: aspect "Max_Entry_Queue_Length" for "CC" previously given at
line 63
fail.ads:69:15: aspect "Max_Entry_Queue_Length" must apply to a protected entry
fail.ads:72:07: pragma "Max_Entry_Queue_Length" must apply to a protected entry
fail.ads:75:15: aspect "Max_Entry_Queue_Length" must apply to a protected entry
fail.ads:78:07: pragma "Max_Entry_Queue_Length" must apply to a protected entry
fail.ads:83:35: entity for aspect "Max_Entry_Queue_Length" must be positive
fail.ads:86:35: entity for aspect "Max_Entry_Queue_Length" must be positive
fail.ads:89:35: entity for aspect "Max_Entry_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

2019-08-13  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_Entry_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_Length so that it can be processed as a
	pragma in addition to a restriction and add an entry for the
	pragma itself.

From-SVN: r274346

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 920650b9010d01192a9fddf9de250d4aea0a6cf9..3acda6af652223b3b4d68dc04eb658fa2e8dd8cf 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,17 @@
+2019-08-13  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_Entry_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_Length so that it can be processed as a
+       pragma in addition to a restriction and add an entry for the
+       pragma itself.
+
 2019-08-13  Yannick Moy  <moy@adacore.com>
 
        * sem_ch4.adb (Analyze_Allocator): Do not insert subtype

diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index 4618749d969e95e03ff825ab158744a64999cd84..d582abf7ff54aa2fe9f892736059b533fcf57634 100644 (file)
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -572,6 +572,7 @@ package body Aspects is
     Aspect_Lock_Free                    => Aspect_Lock_Free,
     Aspect_Machine_Radix                => Aspect_Machine_Radix,
     Aspect_Max_Entry_Queue_Depth        => Aspect_Max_Entry_Queue_Depth,
+    Aspect_Max_Entry_Queue_Length       => Aspect_Max_Entry_Queue_Length,
     Aspect_Max_Queue_Length             => Aspect_Max_Queue_Length,
     Aspect_No_Caching                   => Aspect_No_Caching,
     Aspect_No_Elaboration_Code_All      => Aspect_No_Elaboration_Code_All,

diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 86eb72292a0c0d39a6b3d1cbc8f46bc09633777a..64b0ff77b4bfb8cb18980f11406e4f434f09db55 100644 (file)
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -116,7 +116,8 @@ package Aspects is
       Aspect_Link_Name,
       Aspect_Linker_Section,                -- GNAT
       Aspect_Machine_Radix,
-      Aspect_Max_Entry_Queue_Depth,
+      Aspect_Max_Entry_Queue_Depth,         -- GNAT
+      Aspect_Max_Entry_Queue_Length,
       Aspect_Max_Queue_Length,              -- GNAT
       Aspect_No_Caching,                    -- GNAT
       Aspect_Object_Size,                   -- GNAT
@@ -253,6 +254,7 @@ package Aspects is
       Aspect_Invariant                  => True,
       Aspect_Lock_Free                  => True,
       Aspect_Max_Entry_Queue_Depth      => True,
+      Aspect_Max_Entry_Queue_Length     => True,
       Aspect_Max_Queue_Length           => True,
       Aspect_Object_Size                => True,
       Aspect_Persistent_BSS             => True,
@@ -376,6 +378,7 @@ package Aspects is
       Aspect_Linker_Section             => Expression,
       Aspect_Machine_Radix              => Expression,
       Aspect_Max_Entry_Queue_Depth      => Expression,
+      Aspect_Max_Entry_Queue_Length     => Expression,
       Aspect_Max_Queue_Length           => Expression,
       Aspect_No_Caching                 => Optional_Expression,
       Aspect_Object_Size                => Expression,
@@ -487,6 +490,7 @@ package Aspects is
       Aspect_Lock_Free                    => Name_Lock_Free,
       Aspect_Machine_Radix                => Name_Machine_Radix,
       Aspect_Max_Entry_Queue_Depth        => Name_Max_Entry_Queue_Depth,
+      Aspect_Max_Entry_Queue_Length       => Name_Max_Entry_Queue_Length,
       Aspect_Max_Queue_Length             => Name_Max_Queue_Length,
       Aspect_No_Caching                   => Name_No_Caching,
       Aspect_No_Elaboration_Code_All      => Name_No_Elaboration_Code_All,
@@ -765,6 +769,7 @@ package Aspects is
       Aspect_Initial_Condition            => Never_Delay,
       Aspect_Initializes                  => Never_Delay,
       Aspect_Max_Entry_Queue_Depth        => Never_Delay,
+      Aspect_Max_Entry_Queue_Length       => Never_Delay,
       Aspect_Max_Queue_Length             => Never_Delay,
       Aspect_No_Caching                   => Never_Delay,
       Aspect_No_Elaboration_Code_All      => Never_Delay,

diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index 9042b97d3f992d7820f87302647f6c591bf4192d..bed22e198e2f79c1881514bd6388a7061a8a0109 100644 (file)
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -1415,6 +1415,7 @@ begin
          | Pragma_Main
          | Pragma_Main_Storage
          | Pragma_Max_Entry_Queue_Depth
+         | Pragma_Max_Entry_Queue_Length
          | 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 5ec34872964e353708c28b43a9bc8401ea4ab263..4ce248f3d0c01ed37d063780aece3b29eb287225 100644 (file)
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -3014,6 +3014,19 @@ package body Sem_Ch13 is
                   Insert_Pragma (Aitem);
                   goto Continue;
 
+               --  Max_Entry_Queue_Length
+
+               when Aspect_Max_Entry_Queue_Length =>
+                  Make_Aitem_Pragma
+                    (Pragma_Argument_Associations => New_List (
+                       Make_Pragma_Argument_Association (Loc,
+                         Expression => Relocate_Node (Expr))),
+                     Pragma_Name => Name_Max_Entry_Queue_Length);
+
+                  Decorate (Aspect, Aitem);
+                  Insert_Pragma (Aitem);
+                  goto Continue;
+
                --  Max_Queue_Length
 
                when Aspect_Max_Queue_Length =>
@@ -9651,6 +9664,7 @@ package body Sem_Ch13 is
             | Aspect_Initial_Condition
             | Aspect_Initializes
             | Aspect_Max_Entry_Queue_Depth
+            | Aspect_Max_Entry_Queue_Length
             | Aspect_Max_Queue_Length
             | Aspect_No_Caching
             | Aspect_Obsolescent

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 30b6088798f658fd75f3914b1a24699de5c7c4ea..0f822bf0238744e491539ed4222569ee92d4cbe9 100644 (file)
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -19572,16 +19572,18 @@ package body Sem_Prag is
             end loop;
          end Main_Storage;
 
-         ----------------------
-         -- Max_Queue_Length --
-         ----------------------
+         ----------------------------
+         -- Max_Entry_Queue_Length --
+         ----------------------------
 
-         --  pragma Max_Queue_Length (static_integer_EXPRESSION);
+         --  pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
 
-         --  This processing is shared by Pragma_Max_Entry_Queue_Depth
+         --  This processing is shared by Pragma_Max_Entry_Queue_Depth and
+         --  Pragma_Max_Queue_Length.
 
-         when Pragma_Max_Queue_Length
+         when Pragma_Max_Entry_Queue_Length
             | Pragma_Max_Entry_Queue_Depth
+            | Pragma_Max_Queue_Length
          =>
          Max_Queue_Length : declare
             Arg        : Node_Id;
@@ -19590,7 +19592,9 @@ package body Sem_Prag is
             Val        : Uint;
 
          begin
-            if Prag_Id = Pragma_Max_Queue_Length then
+            if Prag_Id = Pragma_Max_Entry_Queue_Depth
+              or else Prag_Id = Pragma_Max_Queue_Length
+            then
                GNAT_Pragma;
             end if;
 
@@ -31059,6 +31063,7 @@ package body Sem_Prag is
       Pragma_Main                           => -1,
       Pragma_Main_Storage                   => -1,
       Pragma_Max_Entry_Queue_Depth          =>  0,
+      Pragma_Max_Entry_Queue_Length         =>  0,
       Pragma_Max_Queue_Length               =>  0,
       Pragma_Memory_Size                    =>  0,
       Pragma_No_Body                        =>  0,

diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index 941a72387c383125e1dbd55f66656ce209d2da43..4978299c4f0a02799bac6e6996631ae7d4cf17d8 100644 (file)
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -399,6 +399,7 @@ package Sem_Prag is
    --    Global
    --    Initializes
    --    Max_Entry_Queue_Depth
+   --    Max_Entry_Queue_Length
    --    Max_Queue_Length
    --    Post
    --    Post_Class

diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index ef6b17c1e0f80d94f4f56ad6db43af670ae34b3e..d7507a2631c5e7c01483af985bcbe62feb00ded3 100644 (file)
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -592,7 +592,8 @@ 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_Entry_Queue_Depth          : constant Name_Id := N + $; -- GNAT
+   Name_Max_Entry_Queue_Length         : 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
@@ -782,7 +783,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_Length         : constant Name_Id := N + $;
    Name_Max_Size                       : constant Name_Id := N + $;
    Name_Mechanism                      : constant Name_Id := N + $;
    Name_Message                        : constant Name_Id := N + $;
@@ -2007,6 +2007,7 @@ package Snames is
       Pragma_Main,
       Pragma_Main_Storage,
       Pragma_Max_Entry_Queue_Depth,
+      Pragma_Max_Entry_Queue_Length,
       Pragma_Max_Queue_Length,
       Pragma_Memory_Size,
       Pragma_No_Body,