2004-09-09 Vincent Celier <celier@gnat.com>

[pf3gnuchains/gcc-fork.git] / gcc / ada / s-tpoben.adb

diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb
index a195828..c1d7d3c 100644 (file)
--- a/gcc/ada/s-tpoben.adb
+++ b/gcc/ada/s-tpoben.adb
@@ -44,6 +44,7 @@
 
 with Ada.Exceptions;
 --  used for Exception_Occurrence_Access
+--           Raise_Exception
 
 with System.Task_Primitives.Operations;
 --  used for Initialize_Lock
@@ -72,6 +73,10 @@ package body System.Tasking.Protected_Objects.Entries is
    use Task_Primitives.Operations;
    use Ada.Exceptions;
 
+   ----------------
+   -- Local Data --
+   ----------------
+
    Locking_Policy : Character;
    pragma Import (C, Locking_Policy, "__gl_locking_policy");
 
@@ -216,13 +221,36 @@ package body System.Tasking.Protected_Objects.Entries is
    ------------------
 
    procedure Lock_Entries
-     (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) is
+     (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean)
+   is
    begin
       if Object.Finalized then
          Raise_Exception
            (Program_Error'Identity, "Protected Object is finalized");
       end if;
 
+      --  If pragma Detect_Blocking is active then Program_Error must
+      --  be raised if this potentially blocking operation is called from
+      --  a protected action, and the protected object nesting level
+      --  must be increased.
+
+      if Detect_Blocking then
+         declare
+            Self_Id : constant Task_Id := STPO.Self;
+         begin
+            if Self_Id.Common.Protected_Action_Nesting > 0  then
+               Ada.Exceptions.Raise_Exception
+                 (Program_Error'Identity, "potentially blocking operation");
+            else
+               --  We are entering in a protected action, so that we
+               --  increase the protected object nesting level.
+
+               Self_Id.Common.Protected_Action_Nesting :=
+                 Self_Id.Common.Protected_Action_Nesting + 1;
+            end if;
+         end;
+      end if;
+
       --  The lock is made without defering abortion.
 
       --  Therefore the abortion has to be deferred before calling this
@@ -239,14 +267,9 @@ package body System.Tasking.Protected_Objects.Entries is
 
    procedure Lock_Entries (Object : Protection_Entries_Access) is
       Ceiling_Violation : Boolean;
-   begin
-      if Object.Finalized then
-         Raise_Exception
-           (Program_Error'Identity, "Protected Object is finalized");
-      end if;
 
-      pragma Assert (STPO.Self.Deferral_Level > 0);
-      Write_Lock (Object.L'Access, Ceiling_Violation);
+   begin
+      Lock_Entries (Object, Ceiling_Violation);
 
       if Ceiling_Violation then
          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
@@ -259,12 +282,35 @@ package body System.Tasking.Protected_Objects.Entries is
 
    procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
       Ceiling_Violation : Boolean;
+
    begin
       if Object.Finalized then
          Raise_Exception
            (Program_Error'Identity, "Protected Object is finalized");
       end if;
 
+      --  If pragma Detect_Blocking is active then Program_Error must be
+      --  raised if this potentially blocking operation is called from a
+      --  protected action, and the protected object nesting level must
+      --  be increased.
+
+      if Detect_Blocking then
+         declare
+            Self_Id : constant Task_Id := STPO.Self;
+         begin
+            if Self_Id.Common.Protected_Action_Nesting > 0  then
+               Ada.Exceptions.Raise_Exception
+                 (Program_Error'Identity, "potentially blocking operation");
+            else
+               --  We are entering in a protected action, so that we
+               --  increase the protected object nesting level.
+
+               Self_Id.Common.Protected_Action_Nesting :=
+                 Self_Id.Common.Protected_Action_Nesting + 1;
+            end if;
+         end;
+      end if;
+
       Read_Lock (Object.L'Access, Ceiling_Violation);
 
       if Ceiling_Violation then
@@ -278,6 +324,24 @@ package body System.Tasking.Protected_Objects.Entries is
 
    procedure Unlock_Entries (Object : Protection_Entries_Access) is
    begin
+      --  We are exiting from a protected action, so that we decrease the
+      --  protected object nesting level (if pragma Detect_Blocking is
+      --  active).
+
+      if Detect_Blocking then
+         declare
+            Self_Id : constant Task_Id := Self;
+         begin
+            --  Cannot call this procedure without being within a protected
+            --  action.
+
+            pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0);
+
+            Self_Id.Common.Protected_Action_Nesting :=
+              Self_Id.Common.Protected_Action_Nesting - 1;
+         end;
+      end if;
+
       Unlock (Object.L'Access);
    end Unlock_Entries;