1------------------------------------------------------------------------------
2--                                                                          --
3--                        GNAT RUN-TIME COMPONENTS                          --
4--                                                                          --
5--              A D A . T A S K _ I D E N T I F I C A T I O N               --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
10--                                                                          --
11-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32with System.Address_Image;
33with System.Parameters;
34with System.Soft_Links;
35with System.Task_Primitives;
36with System.Task_Primitives.Operations;
37with Ada.Unchecked_Conversion;
38
39pragma Warnings (Off);
40--  Allow withing of non-Preelaborated units in Ada 2005 mode where this
41--  package will be categorized as Preelaborate. See AI-362 for details.
42--  It is safe in the context of the run-time to violate the rules.
43
44with System.Tasking.Utilities;
45
46pragma Warnings (On);
47
48package body Ada.Task_Identification is
49
50   use System.Parameters;
51
52   package STPO renames System.Task_Primitives.Operations;
53
54   -----------------------
55   -- Local Subprograms --
56   -----------------------
57
58   function Convert_Ids (T : Task_Id) return System.Tasking.Task_Id;
59   function Convert_Ids (T : System.Tasking.Task_Id) return Task_Id;
60   pragma Inline (Convert_Ids);
61   --  Conversion functions between different forms of Task_Id
62
63   ---------
64   -- "=" --
65   ---------
66
67   function "=" (Left, Right : Task_Id) return Boolean is
68   begin
69      return System.Tasking."=" (Convert_Ids (Left), Convert_Ids (Right));
70   end "=";
71
72   -----------------
73   -- Abort_Task --
74   ----------------
75
76   procedure Abort_Task (T : Task_Id) is
77   begin
78      if T = Null_Task_Id then
79         raise Program_Error;
80      else
81         System.Tasking.Utilities.Abort_Tasks
82           (System.Tasking.Task_List'(1 => Convert_Ids (T)));
83      end if;
84   end Abort_Task;
85
86   ----------------------------
87   -- Activation_Is_Complete --
88   ----------------------------
89
90   function Activation_Is_Complete (T : Task_Id) return Boolean is
91      use type System.Tasking.Task_Id;
92   begin
93      return Convert_Ids (T).Common.Activator = null;
94   end Activation_Is_Complete;
95
96   -----------------
97   -- Convert_Ids --
98   -----------------
99
100   function Convert_Ids (T : Task_Id) return System.Tasking.Task_Id is
101   begin
102      return System.Tasking.Task_Id (T);
103   end Convert_Ids;
104
105   function Convert_Ids (T : System.Tasking.Task_Id) return Task_Id is
106   begin
107      return Task_Id (T);
108   end Convert_Ids;
109
110   ------------------
111   -- Current_Task --
112   ------------------
113
114   function Current_Task return Task_Id is
115   begin
116      return Convert_Ids (System.Task_Primitives.Operations.Self);
117   end Current_Task;
118
119   ----------------------
120   -- Environment_Task --
121   ----------------------
122
123   function Environment_Task return Task_Id is
124   begin
125      return Convert_Ids (System.Task_Primitives.Operations.Environment_Task);
126   end Environment_Task;
127
128   -----------
129   -- Image --
130   -----------
131
132   function Image (T : Task_Id) return String is
133      function To_Address is new
134        Ada.Unchecked_Conversion
135          (Task_Id, System.Task_Primitives.Task_Address);
136
137   begin
138      if T = Null_Task_Id then
139         return "";
140
141      elsif T.Common.Task_Image_Len = 0 then
142         return System.Address_Image (To_Address (T));
143
144      else
145         return T.Common.Task_Image (1 .. T.Common.Task_Image_Len)
146            & "_" &  System.Address_Image (To_Address (T));
147      end if;
148   end Image;
149
150   -----------------
151   -- Is_Callable --
152   -----------------
153
154   function Is_Callable (T : Task_Id) return Boolean is
155      Result : Boolean;
156      Id     : constant System.Tasking.Task_Id := Convert_Ids (T);
157   begin
158      if T = Null_Task_Id then
159         raise Program_Error;
160      else
161         System.Soft_Links.Abort_Defer.all;
162
163         if Single_Lock then
164            STPO.Lock_RTS;
165         end if;
166
167         STPO.Write_Lock (Id);
168         Result := Id.Callable;
169         STPO.Unlock (Id);
170
171         if Single_Lock then
172            STPO.Unlock_RTS;
173         end if;
174
175         System.Soft_Links.Abort_Undefer.all;
176         return Result;
177      end if;
178   end Is_Callable;
179
180   -------------------
181   -- Is_Terminated --
182   -------------------
183
184   function Is_Terminated (T : Task_Id) return Boolean is
185      Result : Boolean;
186      Id     : constant System.Tasking.Task_Id := Convert_Ids (T);
187
188      use System.Tasking;
189
190   begin
191      if T = Null_Task_Id then
192         raise Program_Error;
193      else
194         System.Soft_Links.Abort_Defer.all;
195
196         if Single_Lock then
197            STPO.Lock_RTS;
198         end if;
199
200         STPO.Write_Lock (Id);
201         Result := Id.Common.State = Terminated;
202         STPO.Unlock (Id);
203
204         if Single_Lock then
205            STPO.Unlock_RTS;
206         end if;
207
208         System.Soft_Links.Abort_Undefer.all;
209         return Result;
210      end if;
211   end Is_Terminated;
212
213end Ada.Task_Identification;
214