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;