A Boolean aspect Exclusive_Functions is added to the language to change
the semantic of protected functions to use a R/W lock instead of a Read
lock.
Tested on x86_64-pc-linux-gnu, committed on trunk
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.diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
--- 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
--- 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
--- 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
--- 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 + $;
