Skip to content

R
riscv-gcc-1
Commit 4de811c5 by Justin Squirek Committed by Pierre-Marie de Rodat
Options

[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
parent ebad47fc
Showing with 52 additions and 10 deletions
gcc/ada/ChangeLog
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> 2019-08-13 Yannick Moy <moy@adacore.com>
* sem_ch4.adb (Analyze_Allocator): Do not insert subtype * sem_ch4.adb (Analyze_Allocator): Do not insert subtype
......
gcc/ada/aspects.adb
...@@ -572,6 +572,7 @@ package body Aspects is ...@@ -572,6 +572,7 @@ package body Aspects is
Aspect_Lock_Free => Aspect_Lock_Free, Aspect_Lock_Free => Aspect_Lock_Free,
Aspect_Machine_Radix => Aspect_Machine_Radix, Aspect_Machine_Radix => Aspect_Machine_Radix,
Aspect_Max_Entry_Queue_Depth => Aspect_Max_Entry_Queue_Depth, 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_Max_Queue_Length => Aspect_Max_Queue_Length,
Aspect_No_Caching => Aspect_No_Caching, Aspect_No_Caching => Aspect_No_Caching,
Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All, Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All,
......
gcc/ada/aspects.ads
...@@ -116,7 +116,8 @@ package Aspects is ...@@ -116,7 +116,8 @@ package Aspects is
Aspect_Link_Name, Aspect_Link_Name,
Aspect_Linker_Section, -- GNAT Aspect_Linker_Section, -- GNAT
Aspect_Machine_Radix, 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_Max_Queue_Length, -- GNAT
Aspect_No_Caching, -- GNAT Aspect_No_Caching, -- GNAT
Aspect_Object_Size, -- GNAT Aspect_Object_Size, -- GNAT
...@@ -253,6 +254,7 @@ package Aspects is ...@@ -253,6 +254,7 @@ package Aspects is
Aspect_Invariant => True, Aspect_Invariant => True,
Aspect_Lock_Free => True, Aspect_Lock_Free => True,
Aspect_Max_Entry_Queue_Depth => True, Aspect_Max_Entry_Queue_Depth => True,
Aspect_Max_Entry_Queue_Length => True,
Aspect_Max_Queue_Length => True, Aspect_Max_Queue_Length => True,
Aspect_Object_Size => True, Aspect_Object_Size => True,
Aspect_Persistent_BSS => True, Aspect_Persistent_BSS => True,
...@@ -376,6 +378,7 @@ package Aspects is ...@@ -376,6 +378,7 @@ package Aspects is
Aspect_Linker_Section => Expression, Aspect_Linker_Section => Expression,
Aspect_Machine_Radix => Expression, Aspect_Machine_Radix => Expression,
Aspect_Max_Entry_Queue_Depth => Expression, Aspect_Max_Entry_Queue_Depth => Expression,
Aspect_Max_Entry_Queue_Length => Expression,
Aspect_Max_Queue_Length => Expression, Aspect_Max_Queue_Length => Expression,
Aspect_No_Caching => Optional_Expression, Aspect_No_Caching => Optional_Expression,
Aspect_Object_Size => Expression, Aspect_Object_Size => Expression,
...@@ -487,6 +490,7 @@ package Aspects is ...@@ -487,6 +490,7 @@ package Aspects is
Aspect_Lock_Free => Name_Lock_Free, Aspect_Lock_Free => Name_Lock_Free,
Aspect_Machine_Radix => Name_Machine_Radix, Aspect_Machine_Radix => Name_Machine_Radix,
Aspect_Max_Entry_Queue_Depth => Name_Max_Entry_Queue_Depth, 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_Max_Queue_Length => Name_Max_Queue_Length,
Aspect_No_Caching => Name_No_Caching, Aspect_No_Caching => Name_No_Caching,
Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All, Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All,
...@@ -765,6 +769,7 @@ package Aspects is ...@@ -765,6 +769,7 @@ package Aspects is
Aspect_Initial_Condition => Never_Delay, Aspect_Initial_Condition => Never_Delay,
Aspect_Initializes => Never_Delay, Aspect_Initializes => Never_Delay,
Aspect_Max_Entry_Queue_Depth => Never_Delay, Aspect_Max_Entry_Queue_Depth => Never_Delay,
Aspect_Max_Entry_Queue_Length => Never_Delay,
Aspect_Max_Queue_Length => Never_Delay, Aspect_Max_Queue_Length => Never_Delay,
Aspect_No_Caching => Never_Delay, Aspect_No_Caching => Never_Delay,
Aspect_No_Elaboration_Code_All => Never_Delay, Aspect_No_Elaboration_Code_All => Never_Delay,
......
gcc/ada/par-prag.adb
...@@ -1415,6 +1415,7 @@ begin ...@@ -1415,6 +1415,7 @@ begin
| Pragma_Main | Pragma_Main
| Pragma_Main_Storage | Pragma_Main_Storage
| Pragma_Max_Entry_Queue_Depth | Pragma_Max_Entry_Queue_Depth
| Pragma_Max_Entry_Queue_Length
| Pragma_Max_Queue_Length | Pragma_Max_Queue_Length
| Pragma_Memory_Size | Pragma_Memory_Size
| Pragma_No_Body | Pragma_No_Body
......
gcc/ada/sem_ch13.adb
...@@ -3014,6 +3014,19 @@ package body Sem_Ch13 is ...@@ -3014,6 +3014,19 @@ package body Sem_Ch13 is
Insert_Pragma (Aitem); Insert_Pragma (Aitem);
goto Continue; 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 -- Max_Queue_Length
when Aspect_Max_Queue_Length => when Aspect_Max_Queue_Length =>
...@@ -9651,6 +9664,7 @@ package body Sem_Ch13 is ...@@ -9651,6 +9664,7 @@ package body Sem_Ch13 is
| Aspect_Initial_Condition | Aspect_Initial_Condition
| Aspect_Initializes | Aspect_Initializes
| Aspect_Max_Entry_Queue_Depth | Aspect_Max_Entry_Queue_Depth
| Aspect_Max_Entry_Queue_Length
| Aspect_Max_Queue_Length | Aspect_Max_Queue_Length
| Aspect_No_Caching | Aspect_No_Caching
| Aspect_Obsolescent | Aspect_Obsolescent
......
gcc/ada/sem_prag.adb
...@@ -19572,16 +19572,18 @@ package body Sem_Prag is ...@@ -19572,16 +19572,18 @@ package body Sem_Prag is
end loop; end loop;
end Main_Storage; 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_Entry_Queue_Depth
| Pragma_Max_Queue_Length
=> =>
Max_Queue_Length : declare Max_Queue_Length : declare
Arg : Node_Id; Arg : Node_Id;
...@@ -19590,7 +19592,9 @@ package body Sem_Prag is ...@@ -19590,7 +19592,9 @@ package body Sem_Prag is
Val : Uint; Val : Uint;
begin 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; GNAT_Pragma;
end if; end if;
...@@ -31059,6 +31063,7 @@ package body Sem_Prag is ...@@ -31059,6 +31063,7 @@ package body Sem_Prag is
Pragma_Main => -1, Pragma_Main => -1,
Pragma_Main_Storage => -1, Pragma_Main_Storage => -1,
Pragma_Max_Entry_Queue_Depth => 0, Pragma_Max_Entry_Queue_Depth => 0,
Pragma_Max_Entry_Queue_Length => 0,
Pragma_Max_Queue_Length => 0, Pragma_Max_Queue_Length => 0,
Pragma_Memory_Size => 0, Pragma_Memory_Size => 0,
Pragma_No_Body => 0, Pragma_No_Body => 0,
gcc/ada/sem_prag.ads
...@@ -399,6 +399,7 @@ package Sem_Prag is ...@@ -399,6 +399,7 @@ package Sem_Prag is
-- Global -- Global
-- Initializes -- Initializes
-- Max_Entry_Queue_Depth -- Max_Entry_Queue_Depth
-- Max_Entry_Queue_Length
-- Max_Queue_Length -- Max_Queue_Length
-- Post -- Post
-- Post_Class -- Post_Class
......
gcc/ada/snames.ads-tmpl
...@@ -592,7 +592,8 @@ package Snames is ...@@ -592,7 +592,8 @@ package Snames is
Name_Machine_Attribute : constant Name_Id := N + $; -- GNAT Name_Machine_Attribute : constant Name_Id := N + $; -- GNAT
Name_Main : constant Name_Id := N + $; -- GNAT Name_Main : constant Name_Id := N + $; -- GNAT
Name_Main_Storage : 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_Max_Queue_Length : constant Name_Id := N + $; -- GNAT
Name_Memory_Size : constant Name_Id := N + $; -- Ada 83 Name_Memory_Size : constant Name_Id := N + $; -- Ada 83
Name_No_Body : constant Name_Id := N + $; -- GNAT Name_No_Body : constant Name_Id := N + $; -- GNAT
...@@ -782,7 +783,6 @@ package Snames is ...@@ -782,7 +783,6 @@ package Snames is
Name_Link_Name : constant Name_Id := N + $; Name_Link_Name : constant Name_Id := N + $;
Name_Low_Order_First : constant Name_Id := N + $; Name_Low_Order_First : constant Name_Id := N + $;
Name_Lowercase : 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_Max_Size : constant Name_Id := N + $;
Name_Mechanism : constant Name_Id := N + $; Name_Mechanism : constant Name_Id := N + $;
Name_Message : constant Name_Id := N + $; Name_Message : constant Name_Id := N + $;
...@@ -2007,6 +2007,7 @@ package Snames is ...@@ -2007,6 +2007,7 @@ package Snames is
Pragma_Main, Pragma_Main,
Pragma_Main_Storage, Pragma_Main_Storage,
Pragma_Max_Entry_Queue_Depth, Pragma_Max_Entry_Queue_Depth,
Pragma_Max_Entry_Queue_Length,
Pragma_Max_Queue_Length, Pragma_Max_Queue_Length,
Pragma_Memory_Size, Pragma_Memory_Size,
Pragma_No_Body, Pragma_No_Body,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment