From 656d1fba78c6a743d8d65a1383400a756dfd9222 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Wed, 30 May 2018 08:58:33 +0000 Subject: [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 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 --- gcc/ada/ChangeLog | 12 ++++++++++++ gcc/ada/aspects.adb | 1 + gcc/ada/aspects.ads | 5 +++++ gcc/ada/par-prag.adb | 1 + gcc/ada/sem_ch13.adb | 14 ++++++++++++++ gcc/ada/sem_prag.adb | 13 +++++++++++-- gcc/ada/sem_prag.ads | 1 + gcc/ada/snames.ads-tmpl | 3 ++- 8 files changed, 47 insertions(+), 3 deletions(-) (limited to 'gcc/ada') 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 + + * 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 * 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, -- cgit v1.1