[Ada] Add new locking policy to support concurrent readers

Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb	(revision 179247)
+++ exp_ch9.adb	(working copy)
@@ -3243,6 +3243,7 @@ 
       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 @@ 
                 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 @@ 
             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 =>
Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi	(revision 179247)
+++ gnat_rm.texi	(working copy)
@@ -7916,8 +7916,9 @@ 
 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
Index: rtsfind.ads
===================================================================
--- rtsfind.ads	(revision 179247)
+++ rtsfind.ads	(working copy)
@@ -1653,6 +1653,7 @@ 
      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 @@ 
      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,
Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 179247)
+++ sem_prag.adb	(working copy)
@@ -10834,17 +10834,24 @@ 
          --  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
             then
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl	(revision 179247)
+++ snames.ads-tmpl	(working copy)
@@ -909,13 +909,10 @@ 
 
    --  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 @@ 
 
    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 --
Index: s-taprob.ads
===================================================================
--- s-taprob.ads	(revision 179247)
+++ s-taprob.ads	(working copy)
@@ -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 @@ 
    --  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;