1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . S O F T _ L I N K S --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
35 -- We must turn polling off for this unit, because otherwise we get an
36 -- infinite loop from the code within the Poll routine itself.
38 with System.Parameters;
40 pragma Warnings (Off);
41 -- Disable warnings since System.Secondary_Stack is currently not Preelaborate
42 with System.Secondary_Stack;
45 package body System.Soft_Links is
47 package SST renames System.Secondary_Stack;
49 NT_Exc_Stack : array (0 .. 8192) of aliased Character;
50 for NT_Exc_Stack'Alignment use Standard'Maximum_Alignment;
51 -- Allocate an exception stack for the main program to use.
52 -- This is currently only used under VMS.
55 -- Note: we rely on the default initialization of NT_TSD
61 procedure Abort_Defer_NT is
66 ----------------------
67 -- Abort_Handler_NT --
68 ----------------------
70 procedure Abort_Handler_NT is
75 ----------------------
76 -- Abort_Undefer_NT --
77 ----------------------
79 procedure Abort_Undefer_NT is
88 procedure Adafinal_NT is
90 -- Handle normal task termination by the environment task, but only
91 -- for the normal task termination. In the case of Abnormal and
92 -- Unhandled_Exception they must have been handled before, and the
93 -- task termination soft link must have been changed so the task
94 -- termination routine is not executed twice.
96 Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
98 -- Finalize the global list for controlled objects if needed
100 Finalize_Global_List.all;
103 ---------------------------
104 -- Check_Abort_Status_NT --
105 ---------------------------
107 function Check_Abort_Status_NT return Integer is
109 return Boolean'Pos (False);
110 end Check_Abort_Status_NT;
112 ------------------------
113 -- Complete_Master_NT --
114 ------------------------
116 procedure Complete_Master_NT is
119 end Complete_Master_NT;
125 procedure Create_TSD (New_TSD : in out TSD) is
126 use type Parameters.Size_Type;
128 SS_Ratio_Dynamic : constant Boolean :=
129 Parameters.Sec_Stack_Ratio = Parameters.Dynamic;
132 if SS_Ratio_Dynamic then
134 (New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size);
138 -----------------------
139 -- Current_Master_NT --
140 -----------------------
142 function Current_Master_NT return Integer is
145 end Current_Master_NT;
151 procedure Destroy_TSD (Old_TSD : in out TSD) is
153 SST.SS_Free (Old_TSD.Sec_Stack_Addr);
156 ---------------------
157 -- Enter_Master_NT --
158 ---------------------
160 procedure Enter_Master_NT is
165 --------------------------
166 -- Get_Current_Excep_NT --
167 --------------------------
169 function Get_Current_Excep_NT return EOA is
171 return NT_TSD.Current_Excep'Access;
172 end Get_Current_Excep_NT;
174 ---------------------------
175 -- Get_Exc_Stack_Addr_NT --
176 ---------------------------
178 function Get_Exc_Stack_Addr_NT return Address is
180 return NT_Exc_Stack (NT_Exc_Stack'Last)'Address;
181 end Get_Exc_Stack_Addr_NT;
183 -----------------------------
184 -- Get_Exc_Stack_Addr_Soft --
185 -----------------------------
187 function Get_Exc_Stack_Addr_Soft return Address is
189 return Get_Exc_Stack_Addr.all;
190 end Get_Exc_Stack_Addr_Soft;
192 ------------------------
193 -- Get_GNAT_Exception --
194 ------------------------
196 function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is
198 return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all);
199 end Get_GNAT_Exception;
201 ---------------------------
202 -- Get_Jmpbuf_Address_NT --
203 ---------------------------
205 function Get_Jmpbuf_Address_NT return Address is
207 return NT_TSD.Jmpbuf_Address;
208 end Get_Jmpbuf_Address_NT;
210 -----------------------------
211 -- Get_Jmpbuf_Address_Soft --
212 -----------------------------
214 function Get_Jmpbuf_Address_Soft return Address is
216 return Get_Jmpbuf_Address.all;
217 end Get_Jmpbuf_Address_Soft;
219 ---------------------------
220 -- Get_Sec_Stack_Addr_NT --
221 ---------------------------
223 function Get_Sec_Stack_Addr_NT return Address is
225 return NT_TSD.Sec_Stack_Addr;
226 end Get_Sec_Stack_Addr_NT;
228 -----------------------------
229 -- Get_Sec_Stack_Addr_Soft --
230 -----------------------------
232 function Get_Sec_Stack_Addr_Soft return Address is
234 return Get_Sec_Stack_Addr.all;
235 end Get_Sec_Stack_Addr_Soft;
237 -----------------------
238 -- Get_Stack_Info_NT --
239 -----------------------
241 function Get_Stack_Info_NT return Stack_Checking.Stack_Access is
243 return NT_TSD.Pri_Stack_Info'Access;
244 end Get_Stack_Info_NT;
246 -------------------------------
247 -- Null_Finalize_Global_List --
248 -------------------------------
250 procedure Null_Finalize_Global_List is
253 end Null_Finalize_Global_List;
255 ---------------------------
256 -- Set_Jmpbuf_Address_NT --
257 ---------------------------
259 procedure Set_Jmpbuf_Address_NT (Addr : Address) is
261 NT_TSD.Jmpbuf_Address := Addr;
262 end Set_Jmpbuf_Address_NT;
264 procedure Set_Jmpbuf_Address_Soft (Addr : Address) is
266 Set_Jmpbuf_Address (Addr);
267 end Set_Jmpbuf_Address_Soft;
269 ---------------------------
270 -- Set_Sec_Stack_Addr_NT --
271 ---------------------------
273 procedure Set_Sec_Stack_Addr_NT (Addr : Address) is
275 NT_TSD.Sec_Stack_Addr := Addr;
276 end Set_Sec_Stack_Addr_NT;
278 -----------------------------
279 -- Set_Sec_Stack_Addr_Soft --
280 -----------------------------
282 procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is
284 Set_Sec_Stack_Addr (Addr);
285 end Set_Sec_Stack_Addr_Soft;
291 procedure Task_Lock_NT is
300 function Task_Name_NT return String is
305 -------------------------
306 -- Task_Termination_NT --
307 -------------------------
309 procedure Task_Termination_NT (Excep : EO) is
310 pragma Unreferenced (Excep);
313 end Task_Termination_NT;
319 procedure Task_Unlock_NT is
324 -------------------------
325 -- Update_Exception_NT --
326 -------------------------
328 procedure Update_Exception_NT (X : EO := Current_Target_Exception) is
330 Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X);
331 end Update_Exception_NT;
333 end System.Soft_Links;