From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001
From: upstream source tree <ports@midipix.org>
Date: Sun, 15 Mar 2015 20:14:05 -0400
Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified
 gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream
 tarball.

downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.

if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
---
 gcc/testsuite/gnat.dg/curr_task.adb | 134 ++++++++++++++++++++++++++++++++++++
 1 file changed, 134 insertions(+)
 create mode 100644 gcc/testsuite/gnat.dg/curr_task.adb

(limited to 'gcc/testsuite/gnat.dg/curr_task.adb')

diff --git a/gcc/testsuite/gnat.dg/curr_task.adb b/gcc/testsuite/gnat.dg/curr_task.adb
new file mode 100644
index 000000000..628be1759
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/curr_task.adb
@@ -0,0 +1,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;
-- 
cgit v1.2.3