From 4de811c54e9dc78f7bca540125fcce804a39bb7c Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Tue, 13 Aug 2019 08:07:35 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 14 ++++++++++++++ gcc/ada/aspects.adb | 1 + gcc/ada/aspects.ads | 7 ++++++- gcc/ada/par-prag.adb | 1 + gcc/ada/sem_ch13.adb | 14 ++++++++++++++ gcc/ada/sem_prag.adb | 19 ++++++++++++------- gcc/ada/sem_prag.ads | 1 + gcc/ada/snames.ads-tmpl | 5 +++-- 8 files changed, 52 insertions(+), 10 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 920650b9010..3acda6af652 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2019-08-13 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_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 * sem_ch4.adb (Analyze_Allocator): Do not insert subtype diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 4618749d969..d582abf7ff5 100644 --- 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 86eb72292a0..64b0ff77b4b 100644 --- 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 9042b97d3f9..bed22e198e2 100644 --- 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 5ec34872964..4ce248f3d0c 100644 --- 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 30b6088798f..0f822bf0238 100644 --- 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 941a72387c3..4978299c4f0 100644 --- 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 ef6b17c1e0f..d7507a2631c 100644 --- 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, -- 2.30.2