URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gnat.dg/] [curr_task.adb] - Blame information for rev 801

Go to most recent revision | Details | Compare with Previous | View Log


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

Line No.	Rev	Author	Line
1	696	jeremybenn	`-- { 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;`

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gnat.dg/] [curr_task.adb] - Blame information for rev 801