2011-09-27 Pascal Obry <obry@adacore.com>

	* rtsfind.ads: Add RE_Lock_Read_Only into rtsfind circuitry.
	(RE_Id): Add RE_Lock_Read_Only.
	(RE_Unit_Table): Likewise.
	* sem_prag.adb (Process_Convention): Change Pragma_Locking_Policy
	to lift restriction on first character. Handle now the
	Name_Concurrent_Readers_Locking where policy character is set to
	'R'.
	* snames.ads-tmpl (Name_Concurrent_Readers_Locking): New
	constant.
	* exp_ch9.adb (Build_Protected_Subprogram_Body): Generate a
	read only lock for function in protected object.
	* s-taprob.ads (Lock_Read_Only): Remove obsolete comment as
	this routine is now used.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@179248 138bc75d-0d04-0410-961f-82ee72b054a4

7 files changed, 42 insertions, 17 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 097c792e98a..8d34c2e1a7f 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,19 @@
+2011-09-27  Pascal Obry  <obry@adacore.com>
+
+	* rtsfind.ads: Add RE_Lock_Read_Only into rtsfind circuitry.
+	(RE_Id): Add RE_Lock_Read_Only.
+	(RE_Unit_Table): Likewise.
+	* sem_prag.adb (Process_Convention): Change Pragma_Locking_Policy
+	to lift restriction on first character. Handle now the
+	Name_Concurrent_Readers_Locking where policy character is set to
+	'R'.
+	* snames.ads-tmpl (Name_Concurrent_Readers_Locking): New
+	constant.
+	* exp_ch9.adb (Build_Protected_Subprogram_Body): Generate a
+	read only lock for function in protected object.
+	* s-taprob.ads (Lock_Read_Only): Remove obsolete comment as
+	this routine is now used.
+
 2011-09-26  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
 
 	* s-atocou-x86.adb (Decrement): Use %;.
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 5b9d4f8f608..2a8a46481cb 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -3243,6 +3243,7 @@ package body Exp_Ch9 is
       Stmts        : List_Id;
       Object_Parm  : Node_Id;
       Exc_Safe     : Boolean;
+      Lock_Kind    : RE_Id;
 
       function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
       --  Tell whether a given subprogram cannot raise an exception
@@ -3389,12 +3390,16 @@ package body Exp_Ch9 is
                 Parameter_Associations => Uactuals));
          end if;
 
+         Lock_Kind := RE_Lock_Read_Only;
+
       else
          Unprot_Call :=
            Make_Procedure_Call_Statement (Loc,
              Name =>
                Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))),
              Parameter_Associations => Uactuals);
+
+         Lock_Kind := RE_Lock;
       end if;
 
       --  Wrap call in block that will be covered by an at_end handler
@@ -3419,7 +3424,7 @@ package body Exp_Ch9 is
             Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
 
          when System_Tasking_Protected_Objects =>
-            Lock_Name := New_Reference_To (RTE (RE_Lock), Loc);
+            Lock_Name := New_Reference_To (RTE (Lock_Kind), Loc);
             Service_Name := New_Reference_To (RTE (RE_Unlock), Loc);
 
          when others =>
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 7e9ff7d8b7e..6e99fcc046c 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -7916,8 +7916,9 @@ Not followed.  This implementation is not targeted to such a domain.
 The implementation should use names that end with @samp{_Locking} for
 locking policies defined by the implementation.
 @end cartouche
-Followed.  A single implementation-defined locking policy is defined,
-whose name (@code{Inheritance_Locking}) follows this suggestion.
+Followed.  Two implementation-defined locking policies are defined,
+whose names (@code{Inheritance_Locking} and
+@code{Concurrent_Readers_Locking}) follow this suggestion.
 
 @cindex Entry queuing policies
 @unnumberedsec D.4(16): Entry Queuing Policies
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index ddbede2bf04..07bf0121a56 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -1653,6 +1653,7 @@ package Rtsfind is
      RE_Initialize_Protection,           -- System.Tasking.Protected_Objects
      RE_Finalize_Protection,             -- System.Tasking.Protected_Objects
      RE_Lock,                            -- System.Tasking.Protected_Objects
+     RE_Lock_Read_Only,                  -- System.Tasking.Protected_Objects
      RE_Get_Ceiling,                     -- System.Tasking.Protected_Objects
      RE_Set_Ceiling,                     -- System.Tasking.Protected_Objects
      RE_Unlock,                          -- System.Tasking.Protected_Objects
@@ -2883,6 +2884,7 @@ package Rtsfind is
      RE_Initialize_Protection            => System_Tasking_Protected_Objects,
      RE_Finalize_Protection              => System_Tasking_Protected_Objects,
      RE_Lock                             => System_Tasking_Protected_Objects,
+     RE_Lock_Read_Only                   => System_Tasking_Protected_Objects,
      RE_Get_Ceiling                      => System_Tasking_Protected_Objects,
      RE_Set_Ceiling                      => System_Tasking_Protected_Objects,
      RE_Unlock                           => System_Tasking_Protected_Objects,
diff --git a/gcc/ada/s-taprob.ads b/gcc/ada/s-taprob.ads
index 0342f70e031..fa2a99fa794 100644
--- a/gcc/ada/s-taprob.ads
+++ b/gcc/ada/s-taprob.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  S p e c                                 --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNARL is free software; you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -193,10 +193,6 @@ package System.Tasking.Protected_Objects is
    --  has been made by the caller. Other calls to Lock_Read_Only may (but
    --  need not) return before the call to Unlock, and the corresponding
    --  callers will also own the lock for read access.
-   --
-   --  Note: we are not currently using this interface, it is provided
-   --  for possible future use. At the current time, everyone uses Lock
-   --  for both read and write locks.
 
    procedure Set_Ceiling
      (Object : Protection_Access;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 74d889e283a..46906943762 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -10834,16 +10834,23 @@ package body Sem_Prag is
          --  pragma Locking_Policy (policy_IDENTIFIER);
 
          when Pragma_Locking_Policy => declare
-            LP : Character;
-
+            subtype LP_Range is Name_Id
+              range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
+            LP_Val : LP_Range;
+            LP     : Character;
          begin
             Check_Ada_83_Warning;
             Check_Arg_Count (1);
             Check_No_Identifiers;
             Check_Arg_Is_Locking_Policy (Arg1);
             Check_Valid_Configuration_Pragma;
-            Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
-            LP := Fold_Upper (Name_Buffer (1));
+            LP_Val := Chars (Get_Pragma_Arg (Arg1));
+
+            case LP_Val is
+               when Name_Ceiling_Locking            => LP := 'C';
+               when Name_Inheritance_Locking        => LP := 'I';
+               when Name_Concurrent_Readers_Locking => LP := 'R';
+            end case;
 
             if Locking_Policy /= ' '
               and then Locking_Policy /= LP
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 5f321db7f39..f7c441e97aa 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -909,13 +909,10 @@ package Snames is
 
    --  Names of recognized locking policy identifiers
 
-   --  Note: policies are identified by the first character of the
-   --  name (e.g. C for Ceiling_Locking). If new policy names are added,
-   --  the first character must be distinct.
-
    First_Locking_Policy_Name           : constant Name_Id := N + $;
    Name_Ceiling_Locking                : constant Name_Id := N + $;
    Name_Inheritance_Locking            : constant Name_Id := N + $;
+   Name_Concurrent_Readers_Locking     : constant Name_Id := N + $; -- GNAT
    Last_Locking_Policy_Name            : constant Name_Id := N + $;
 
    --  Names of recognized queuing policy identifiers
@@ -1500,7 +1497,8 @@ package Snames is
 
    type Locking_Policy_Id is (
       Locking_Policy_Inheritance_Locking,
-      Locking_Policy_Ceiling_Locking);
+      Locking_Policy_Ceiling_Locking,
+      Locking_Policy_Concurrent_Readers_Locking);
 
    ---------------------------
    -- Pragma ID Definitions --