Subversion Repositories openrisc

-- { dg-do run }

-- { dg-options "-gnatws" }

with Ada.Exceptions;

with Ada.Text_IO;

with Ada.Task_Identification;

procedure Curr_Task is

   use Ada.Task_Identification;

   --  Simple semaphore

   protected Semaphore is

      entry Lock;

      procedure Unlock;

   private

      TID        : Task_Id := Null_Task_Id;

      Lock_Count : Natural := 0;

   end Semaphore;

   ----------

   -- Lock --

   ----------

   procedure Lock is

   begin

      Semaphore.Lock;

   end Lock;

   ---------------

   -- Semaphore --

   ---------------

   protected body Semaphore is

      ----------

      -- Lock --

      ----------

      entry Lock when Lock_Count = 0

        or else TID = Current_Task

      is

      begin

         if not

           (Lock_Count = 0

            or else TID = Lock'Caller)

         then

            Ada.Text_IO.Put_Line

              ("Barrier leaks " & Lock_Count'Img

                 & ' ' & Image (TID)

                 & ' ' & Image (Lock'Caller));

         end if;

         Lock_Count := Lock_Count + 1;

         TID := Lock'Caller;

      end Lock;

      ------------

      -- Unlock --

      ------------

      procedure Unlock is

      begin

         if TID = Current_Task then

            Lock_Count := Lock_Count - 1;

         else

            raise Tasking_Error;

         end if;

      end Unlock;

   end Semaphore;

   ------------

   -- Unlock --

   ------------

   procedure Unlock is

   begin

      Semaphore.Unlock;

   end Unlock;

   task type Secondary is

      entry Start;

   end Secondary;

   procedure Parse (P1 : Positive);

   -----------

   -- Parse --

   -----------

   procedure Parse (P1 : Positive) is

   begin

      Lock;

      delay 0.01;

      if P1 mod 2 = 0 then

         Lock;

         delay 0.01;

         Unlock;

      end if;

      Unlock;

   end Parse;

   ---------------

   -- Secondary --

   ---------------

   task body Secondary is

   begin

      accept Start;

      for K in 1 .. 20 loop

         Parse (K);

      end loop;

      raise Constraint_Error;

   exception

      when Program_Error =>

         null;

   end Secondary;

   TS : array (1 .. 2) of Secondary;

begin

   Parse (1);

   for J in TS'Range loop

      TS (J).Start;

   end loop;

end Curr_Task;