From d22f3eabf11d403a4885b986b33006d21dc431ba Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 30 Jun 2020 03:49:34 -0400 Subject: [PATCH] [Ada] Ada2020: AI12-0129 Make protected objects more protecting gcc/ada/ * aspects.ads, snames.ads-tmpl: Add support for Exclusive_Functions aspect. * sem_ch13.adb (Analyze_Aspect_Specifications): Ditto. * exp_ch9.adb (Build_Protected_Subprogram_Body): Take aspect Exclusive_Functions into account. --- gcc/ada/aspects.ads | 4 ++++ gcc/ada/exp_ch9.adb | 14 ++++++++++++-- gcc/ada/sem_ch13.adb | 19 +++++++++++++++++-- gcc/ada/snames.ads-tmpl | 1 + 4 files changed, 34 insertions(+), 4 deletions(-) diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 03941065b80..72812ff2614 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -190,6 +190,7 @@ package Aspects is Aspect_Disable_Controlled, -- GNAT Aspect_Discard_Names, Aspect_CUDA_Global, -- GNAT + Aspect_Exclusive_Functions, Aspect_Export, Aspect_Favor_Top_Level, -- GNAT Aspect_Independent, @@ -472,6 +473,7 @@ package Aspects is Aspect_Dynamic_Predicate => False, Aspect_Effective_Reads => False, Aspect_Effective_Writes => False, + Aspect_Exclusive_Functions => False, Aspect_Extensions_Visible => False, Aspect_External_Name => False, Aspect_External_Tag => False, @@ -619,6 +621,7 @@ package Aspects is Aspect_Effective_Reads => Name_Effective_Reads, Aspect_Effective_Writes => Name_Effective_Writes, Aspect_Elaborate_Body => Name_Elaborate_Body, + Aspect_Exclusive_Functions => Name_Exclusive_Functions, Aspect_Export => Name_Export, Aspect_Extensions_Visible => Name_Extensions_Visible, Aspect_External_Name => Name_External_Name, @@ -851,6 +854,7 @@ package Aspects is Aspect_Dispatching_Domain => Always_Delay, Aspect_Dynamic_Predicate => Always_Delay, Aspect_Elaborate_Body => Always_Delay, + Aspect_Exclusive_Functions => Always_Delay, Aspect_External_Name => Always_Delay, Aspect_External_Tag => Always_Delay, Aspect_Favor_Top_Level => Always_Delay, diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 9cf90d1c0c1..26e7321ef88 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Aspects; use Aspects; with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; @@ -4089,8 +4090,17 @@ package body Exp_Ch9 is Parameter_Associations => Uactuals)); end if; - Lock_Kind := RE_Lock_Read_Only; - + if Has_Aspect (Pid, Aspect_Exclusive_Functions) + and then + (No (Find_Value_Of_Aspect (Pid, Aspect_Exclusive_Functions)) + or else + Is_True (Static_Boolean (Find_Value_Of_Aspect + (Pid, Aspect_Exclusive_Functions)))) + then + Lock_Kind := RE_Lock; + else + Lock_Kind := RE_Lock_Read_Only; + end if; else Unprot_Call := Make_Procedure_Call_Statement (Loc, diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 661dc5a9e62..e2b8bf8e9b5 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4397,14 +4397,16 @@ package body Sem_Ch13 is if Ekind (E) /= E_Protected_Type then Error_Msg_Name_1 := Nam; Error_Msg_N - ("aspect % only applies to a protected object", + ("aspect % only applies to a protected type " & + "or object", Aspect); else -- Set the Uses_Lock_Free flag to True if there is no -- expression or if the expression is True. The -- evaluation of this aspect should be delayed to the - -- freeze point (why???) + -- freeze point if we wanted to handle the corner case + -- of "true" or "false" being redefined. if No (Expr) or else Is_True (Static_Boolean (Expr)) @@ -4426,6 +4428,19 @@ package body Sem_Ch13 is Analyze_Aspect_Disable_Controlled; goto Continue; + -- Ada 202x (AI12-0129): Exclusive_Functions + + elsif A_Id = Aspect_Exclusive_Functions then + if Ekind (E) /= E_Protected_Type then + Error_Msg_Name_1 := Nam; + Error_Msg_N + ("aspect % only applies to a protected type " & + "or object", + Aspect); + end if; + + goto Continue; + -- Ada 202x (AI12-0075): static expression functions elsif A_Id = Aspect_Static then diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index fa5134f972f..65cc9d5a3eb 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -148,6 +148,7 @@ package Snames is Name_Dimension_System : constant Name_Id := N + $; Name_Disable_Controlled : constant Name_Id := N + $; Name_Dynamic_Predicate : constant Name_Id := N + $; + Name_Exclusive_Functions : constant Name_Id := N + $; Name_Integer_Literal : constant Name_Id := N + $; Name_Real_Literal : constant Name_Id := N + $; Name_Relaxed_Initialization : constant Name_Id := N + $; -- 2.30.2