2005-03-17 Jose Ruiz <ruiz@adacore.com>

	* s-taprob.adb (Initialize_Protection): Initialize the protected
	object's owner to Null_Task.
	(Lock): If pragma Detect_Blocking is in effect and the caller of this
	procedure is already the protected object's owner then Program_Error
	is raised. In addition the protected object's owner is updated.
	(Lock_Read_Only): If pragma Detect_Blocking is in effect and the caller
	of this procedure is already the protected object's owner then
	Program_Error is raised.
	In addition the protected object's owner is updated.
	(Unlock): Remove the ownership of the protected object.

	* s-taprob.ads (Protection): Add the field Owner, used to store the
	protected object's owner.
	This component is needed for detecting one type of potentially blocking
	operations (external calls on a protected subprogram with the same
	target object as that of the protected action). Document the rest of
	the components.

	* s-tposen.adb, s-tpoben.adb (Initialize_Protection_Entries):
	Initialize the protected object's owner to Null_Task.
	(Lock_Read_Only_Entries): If pragma Detect_Blocking is in effect and the
	caller of this procedure is already the protected object's owner then
	Program_Error is raised.
	Do not raise Program_Error when this procedure is called from a
	protected action.
	(Unlock_Entries): Remove the ownership of the protected object.
	(Lock_Entries): If pragma Detect_Blocking is in effect and the caller
	of this procedure is already the protected object's owner then
	Program_Error is raised.
	Do not raise Program_Error when this procedure is called from
	a protected action.

	* s-tposen.ads, s-tpoben.ads (Protection_Entries): Add the field Owner,
	used to store the protected object's owner.

	* s-tpobop.adb (Protected_Entry_Call): If pragma Detect_Blocking is in
	effect and this procedure (a potentially blocking operation) is called
	from whithin a protected action, Program_Error is raised.
	(Timed_Protected_Entry_Call): If pragma Detect_Blocking is in effect
	and this procedure (a potentially blocking operation) is called from
	whithin a protected action, Program_Error is raised.


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

1 files changed, 23 insertions, 1 deletions

diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb
index 3535a79ef74..3ab51b542c8 100644
--- a/gcc/ada/s-tpobop.adb
+++ b/gcc/ada/s-tpobop.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  B o d y                                 --
 --                                                                          --
---         Copyright (C) 1998-2004, Free Software Foundation, Inc.          --
+--         Copyright (C) 1998-2005, 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- --
@@ -537,6 +537,17 @@ package body System.Tasking.Protected_Objects.Operations is
            (Storage_Error'Identity, "not enough ATC nesting levels");
       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.
+
+      if Detect_Blocking
+        and then Self_ID.Common.Protected_Action_Nesting > 0
+      then
+         Ada.Exceptions.Raise_Exception
+           (Program_Error'Identity, "potentially blocking operation");
+      end if;
+
       Initialization.Defer_Abort (Self_ID);
       Lock_Entries (Object, Ceiling_Violation);
 
@@ -889,6 +900,17 @@ package body System.Tasking.Protected_Objects.Operations is
            "not enough ATC nesting levels");
       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.
+
+      if Detect_Blocking
+        and then Self_Id.Common.Protected_Action_Nesting > 0
+      then
+         Ada.Exceptions.Raise_Exception
+           (Program_Error'Identity, "potentially blocking operation");
+      end if;
+
       if Runtime_Traces then
          Send_Trace_Info (POT_Call, Entry_Index (E), Timeout);
       end if;