curr_task.adb

来自「用于进行gcc测试」· ADB 代码 · 共 135 行

-- { 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;