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