135 lines
2.2 KiB
Ada
135 lines
2.2 KiB
Ada
-- { 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;
|