gcc/testsuite/gnat.dg/curr_task.adb

   1 -- { dg-do run }
   2 -- { dg-options "-gnatws" }
   3
   4 with Ada.Exceptions;
   5 with Ada.Text_IO;
   6 with Ada.Task_Identification;
   7
   8 procedure Curr_Task is
   9
  10    use Ada.Task_Identification;
  11
  12    --  Simple semaphore
  13
  14    protected Semaphore is
  15       entry Lock;
  16       procedure Unlock;
  17    private
  18       TID        : Task_Id := Null_Task_Id;
  19       Lock_Count : Natural := 0;
  20    end Semaphore;
  21
  22    ----------
  23    -- Lock --
  24    ----------
  25
  26    procedure Lock is
  27    begin
  28       Semaphore.Lock;
  29    end Lock;
  30
  31    ---------------
  32    -- Semaphore --
  33    ---------------
  34
  35    protected body Semaphore is
  36
  37       ----------
  38       -- Lock --
  39       ----------
  40
  41       entry Lock when Lock_Count = 0
  42         or else TID = Current_Task
  43       is
  44       begin
  45          if not
  46            (Lock_Count = 0
  47             or else TID = Lock'Caller)
  48          then
  49             Ada.Text_IO.Put_Line
  50               ("Barrier leaks " & Lock_Count'Img
  51                  & ' ' & Image (TID)
  52                  & ' ' & Image (Lock'Caller));
  53          end if;
  54
  55          Lock_Count := Lock_Count + 1;
  56          TID := Lock'Caller;
  57       end Lock;
  58
  59       ------------
  60       -- Unlock --
  61       ------------
  62
  63       procedure Unlock is
  64       begin
  65          if TID = Current_Task then
  66             Lock_Count := Lock_Count - 1;
  67          else
  68             raise Tasking_Error;
  69          end if;
  70       end Unlock;
  71
  72    end Semaphore;
  73
  74    ------------
  75    -- Unlock --
  76    ------------
  77
  78    procedure Unlock is
  79    begin
  80       Semaphore.Unlock;
  81    end Unlock;
  82
  83    task type Secondary is
  84       entry Start;
  85    end Secondary;
  86
  87    procedure Parse (P1 : Positive);
  88
  89    -----------
  90    -- Parse --
  91    -----------
  92
  93    procedure Parse (P1 : Positive) is
  94    begin
  95       Lock;
  96       delay 0.01;
  97
  98       if P1 mod 2 = 0 then
  99          Lock;
 100          delay 0.01;
 101          Unlock;
 102       end if;
 103
 104       Unlock;
 105    end Parse;
 106
 107    ---------------
 108    -- Secondary --
 109    ---------------
 110
 111    task body Secondary is
 112    begin
 113       accept Start;
 114
 115       for K in 1 .. 20 loop
 116          Parse (K);
 117       end loop;
 118
 119       raise Constraint_Error;
 120
 121    exception
 122       when Program_Error =>
 123          null;
 124    end Secondary;
 125
 126    TS : array (1 .. 2) of Secondary;
 127
 128 begin
 129    Parse (1);
 130
 131    for J in TS'Range loop
 132       TS (J).Start;
 133    end loop;
 134 end Curr_Task;