[Ada] fix bugs in pragma Detect_Blocking

[Arnaud Charlet <charlet at adacore dot com>]

Tested under i686-linux, committed on mainline.

Fix two errors in the detection of potentially blocking operations in
protected objects:

There was a potentially blocking operation that was not detected when pragma
Detect_Blocking was in effect. It was the case of an external call on a
protected subprogram with the same target object as that of the protected
action (ARM 9.5.1 par. 15). An example of this would be a protected object
(A) which calls an operation on another protected object (B), which in turn
calls a protected operation on the former (A). The latter operation (B -> A)
is a potentially blocking operation that was not detected when pragma
Detect_Blocking was in effect.
It has been fixed by storing the protected object's owner within the protected
object's internal data, so that, when pragma Detect_Blocking is in effect,
Program_Error is raised if the task that tries to get access to the protected
object is already the protected object's owner.
The test case should detect the potentially blocking operation, and hence
raise Program_Error. The expected output from
executing tis test is:
Blocking operation detected
--
pragma Detect_Blocking;
with Tasking_Two_Entries;

procedure Test_Two_Entries is
begin
   Tasking_Two_Entries.Container.Test;
end Test_Two_Entries;
package Tasking_Two_Entries is

   protected Container is
      procedure Test;
      function Check return Boolean;
      entry E1;
      entry E2;
   end Container;

   protected Intermediate is
      function Check return Boolean;
   end Intermediate;

end Tasking_Two_Entries;
with GNAT.IO;

package body Tasking_Two_Entries is

   protected body Container is
      procedure Test is
      begin
         if Intermediate.Check then
            null;
         end if;
      end Test;
      
      function Check return Boolean is
      begin
         return True;
      end Check;

      entry E1 when True is
      begin
         null;
      end E1;

      entry E2 when True is
      begin
         null;
      end E2;


   end Container;
   
   protected body Intermediate is
      function Check return Boolean is
      begin
         return Container.Check;
      exception
         when Program_Error =>
            GNAT.IO.Put_Line ("Blocking operation detected");
            return True;
      end Check;
   end Intermediate;

end Tasking_Two_Entries;

Calls to protected procedures or functions belonging to protected objects with
entries were considered potentially blocking, and hence they raised
Program_Error if called from another protected action (when pragma
Detect_Blocking was in effect). The run time has been modified so that these
calls are no longer considered blocking operations.
The test program exercises this case by calling a protected procedure from
another protected object's protected procedure. No output is expected.
--
pragma Detect_Blocking;
package body Pro is
   protected body A is procedure X is begin B.Y; end X; end A;

   protected body B is
      procedure Y is begin null; end Y;
      entry Z when True is begin null; end Z;
   end B;
end Pro;
package Pro is
   protected A is procedure X; end A;
   protected B is
      procedure Y;
      entry Z;
   end B;
end Pro;
with Pro; use Pro;
procedure Prop is begin A.X; end;

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.

Attachment: difs.16
Description: Text document