From: Arnaud Charlet <charlet@adacore.com>
Date: Tue, 30 Jun 2020 07:49:34 +0000 (-0400)
Subject: [Ada] Ada2020: AI12-0129 Make protected objects more protecting
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=d22f3eabf11d403a4885b986b33006d21dc431ba;p=gcc.git

[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.
---

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 + $;