summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gnat.dg/curr_task.adb
blob: 628be1759daa0253acfb104236cf7eb388a607d4 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
-- { 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;