[Ada] improve handling of pragma Detect_Blocking

[Arnaud Charlet]

Tested on x86-linux, committed on mainline.

pragma Detect_Blocking forces the detection of potentially blocking operations
within protected operations. There is a per-task counter that reflects the
dynamic level of protected action nesting for the different tasks, and if this
value is greater than zero when calling a potentially blocking operation then
Program_Error is raised.
Test program test1.adb exercises some blocking operations in order to check
whether they are properly detected in presence of pragma Detect_Blocking. The
exception handler for Program_Error must execute in all cases, whose effect is
printing the following output: "Test1 passed".
--
$ gnatmake test1
$ test1
--
with Ada.Text_IO;
procedure Test1 is
   protected PO is
      procedure P;
      entry Closed;
   end PO;
   protected body PO is
      entry Closed when False is begin null; end Closed;

      procedure P is
      begin
         select
            Closed; Ada.Text_IO.Put_Line ("Test failed");
         else
            Ada.Text_IO.Put_Line ("Test failed");
         end select;
      exception
         when Program_Error => Ada.Text_IO.Put_Line ("Test1 passed");
      end P;
   end PO;
begin
   PO.P;
end Test1;

2004-11-18  Jose Ruiz  <ruiz@adacore.com>

	* s-tposen.adb (Lock_Entry): Remove the code for raising Program_Error
	for Detect_Blocking which is redundant with the check done within the
	procedure Protected_Single_Entry_Call.
	(Lock_Read_Only_Entry): Remove the code for raising Program_Error for
	Detect_Blocking which is redundant with the check done within the
	procedure Protected_Single_Entry_Call.

-------------- next part --------------
Index: s-tposen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-tposen.adb,v
retrieving revision 1.10
diff -u -p -r1.10 s-tposen.adb
--- s-tposen.adb	4 Oct 2004 14:51:59 -0000	1.10
+++ s-tposen.adb	19 Nov 2004 10:35:29 -0000
@@ -350,25 +350,18 @@ package body System.Tasking.Protected_Ob
       Ceiling_Violation : Boolean;
 
    begin
-      --  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 pragma Detect_Blocking is active then 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;
+            --  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;
       end if;
 
@@ -390,25 +383,18 @@ package body System.Tasking.Protected_Ob
       Ceiling_Violation : Boolean;
 
    begin
-      --  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 pragma Detect_Blocking is active then 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;
+            --  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;
       end if;