1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . S O F T _ L I N K S --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
34 ------------------------------------------------------------------------------
37 -- We must turn polling off for this unit, because otherwise we get
38 -- an infinite loop from the code within the Poll routine itself.
40 with System
.Machine_State_Operations
; use System
.Machine_State_Operations
;
41 -- Used for Create_TSD, Destroy_TSD
43 with System
.Parameters
;
44 -- Used for Sec_Stack_Ratio
46 with System
.Secondary_Stack
;
48 package body System
.Soft_Links
is
50 package SST
renames System
.Secondary_Stack
;
52 -- Allocate an exception stack for the main program to use.
53 -- We make sure that the stack has maximum alignment. Some systems require
54 -- this (e.g. Sun), and in any case it is a good idea for efficiency.
56 NT_Exc_Stack
: array (0 .. 8192) of aliased Character;
57 for NT_Exc_Stack
'Alignment use Standard
'Maximum_Alignment;
65 procedure Abort_Defer_NT
is
70 ----------------------
71 -- Abort_Handler_NT --
72 ----------------------
74 procedure Abort_Handler_NT
is
79 ----------------------
80 -- Abort_Undefer_NT --
81 ----------------------
83 procedure Abort_Undefer_NT
is
88 ---------------------------
89 -- Check_Abort_Status_NT --
90 ---------------------------
92 function Check_Abort_Status_NT
return Integer is
94 return Boolean'Pos (False);
95 end Check_Abort_Status_NT
;
97 ------------------------
98 -- Complete_Master_NT --
99 ------------------------
101 procedure Complete_Master_NT
is
104 end Complete_Master_NT
;
110 procedure Create_TSD
(New_TSD
: in out TSD
) is
111 use type Parameters
.Size_Type
;
113 SS_Ratio_Dynamic
: constant Boolean :=
114 Parameters
.Sec_Stack_Ratio
= Parameters
.Dynamic
;
117 if SS_Ratio_Dynamic
then
119 (New_TSD
.Sec_Stack_Addr
, SST
.Default_Secondary_Stack_Size
);
122 New_TSD
.Machine_State_Addr
:=
124 (System
.Machine_State_Operations
.Allocate_Machine_State
);
127 -----------------------
128 -- Current_Master_NT --
129 -----------------------
131 function Current_Master_NT
return Integer is
134 end Current_Master_NT
;
140 procedure Destroy_TSD
(Old_TSD
: in out TSD
) is
142 SST
.SS_Free
(Old_TSD
.Sec_Stack_Addr
);
143 System
.Machine_State_Operations
.Free_Machine_State
144 (Machine_State
(Old_TSD
.Machine_State_Addr
));
147 ---------------------
148 -- Enter_Master_NT --
149 ---------------------
151 procedure Enter_Master_NT
is
156 --------------------------
157 -- Get_Current_Excep_NT --
158 --------------------------
160 function Get_Current_Excep_NT
return EOA
is
162 return NT_TSD
.Current_Excep
'Access;
163 end Get_Current_Excep_NT
;
165 ---------------------------
166 -- Get_Exc_Stack_Addr_NT --
167 ---------------------------
169 function Get_Exc_Stack_Addr_NT
return Address
is
171 return NT_TSD
.Exc_Stack_Addr
;
172 end Get_Exc_Stack_Addr_NT
;
174 -----------------------------
175 -- Get_Exc_Stack_Addr_Soft --
176 -----------------------------
178 function Get_Exc_Stack_Addr_Soft
return Address
is
180 return Get_Exc_Stack_Addr
.all;
181 end Get_Exc_Stack_Addr_Soft
;
183 ------------------------
184 -- Get_GNAT_Exception --
185 ------------------------
187 function Get_GNAT_Exception
return Ada
.Exceptions
.Exception_Id
is
189 return Ada
.Exceptions
.Exception_Identity
(Get_Current_Excep
.all.all);
190 end Get_GNAT_Exception
;
192 ---------------------------
193 -- Get_Jmpbuf_Address_NT --
194 ---------------------------
196 function Get_Jmpbuf_Address_NT
return Address
is
198 return NT_TSD
.Jmpbuf_Address
;
199 end Get_Jmpbuf_Address_NT
;
201 -----------------------------
202 -- Get_Jmpbuf_Address_Soft --
203 -----------------------------
205 function Get_Jmpbuf_Address_Soft
return Address
is
207 return Get_Jmpbuf_Address
.all;
208 end Get_Jmpbuf_Address_Soft
;
210 -------------------------------
211 -- Get_Machine_State_Addr_NT --
212 -------------------------------
214 function Get_Machine_State_Addr_NT
return Address
is
216 return NT_TSD
.Machine_State_Addr
;
217 end Get_Machine_State_Addr_NT
;
219 ---------------------------------
220 -- Get_Machine_State_Addr_Soft --
221 ---------------------------------
223 function Get_Machine_State_Addr_Soft
return Address
is
225 return Get_Machine_State_Addr
.all;
226 end Get_Machine_State_Addr_Soft
;
228 ---------------------------
229 -- Get_Sec_Stack_Addr_NT --
230 ---------------------------
232 function Get_Sec_Stack_Addr_NT
return Address
is
234 return NT_TSD
.Sec_Stack_Addr
;
235 end Get_Sec_Stack_Addr_NT
;
237 -----------------------------
238 -- Get_Sec_Stack_Addr_Soft --
239 -----------------------------
241 function Get_Sec_Stack_Addr_Soft
return Address
is
243 return Get_Sec_Stack_Addr
.all;
244 end Get_Sec_Stack_Addr_Soft
;
246 -----------------------
247 -- Get_Stack_Info_NT --
248 -----------------------
250 function Get_Stack_Info_NT
return Stack_Checking
.Stack_Access
is
252 return NT_TSD
.Pri_Stack_Info
'Access;
253 end Get_Stack_Info_NT
;
259 procedure Null_Adafinal
is
264 ---------------------------
265 -- Set_Exc_Stack_Addr_NT --
266 ---------------------------
268 procedure Set_Exc_Stack_Addr_NT
(Self_ID
: Address
; Addr
: Address
) is
270 NT_TSD
.Exc_Stack_Addr
:= Addr
;
271 end Set_Exc_Stack_Addr_NT
;
273 -----------------------------
274 -- Set_Exc_Stack_Addr_Soft --
275 -----------------------------
277 procedure Set_Exc_Stack_Addr_Soft
(Self_ID
: Address
; Addr
: Address
) is
279 Set_Exc_Stack_Addr
(Self_ID
, Addr
);
280 end Set_Exc_Stack_Addr_Soft
;
282 ---------------------------
283 -- Set_Jmpbuf_Address_NT --
284 ---------------------------
286 procedure Set_Jmpbuf_Address_NT
(Addr
: Address
) is
288 NT_TSD
.Jmpbuf_Address
:= Addr
;
289 end Set_Jmpbuf_Address_NT
;
291 procedure Set_Jmpbuf_Address_Soft
(Addr
: Address
) is
293 Set_Jmpbuf_Address
(Addr
);
294 end Set_Jmpbuf_Address_Soft
;
296 -------------------------------
297 -- Set_Machine_State_Addr_NT --
298 -------------------------------
300 procedure Set_Machine_State_Addr_NT
(Addr
: Address
) is
302 NT_TSD
.Machine_State_Addr
:= Addr
;
303 end Set_Machine_State_Addr_NT
;
305 ---------------------------------
306 -- Set_Machine_State_Addr_Soft --
307 ---------------------------------
309 procedure Set_Machine_State_Addr_Soft
(Addr
: Address
) is
311 Set_Machine_State_Addr
(Addr
);
312 end Set_Machine_State_Addr_Soft
;
314 ---------------------------
315 -- Set_Sec_Stack_Addr_NT --
316 ---------------------------
318 procedure Set_Sec_Stack_Addr_NT
(Addr
: Address
) is
320 NT_TSD
.Sec_Stack_Addr
:= Addr
;
321 end Set_Sec_Stack_Addr_NT
;
323 -----------------------------
324 -- Set_Sec_Stack_Addr_Soft --
325 -----------------------------
327 procedure Set_Sec_Stack_Addr_Soft
(Addr
: Address
) is
329 Set_Sec_Stack_Addr
(Addr
);
330 end Set_Sec_Stack_Addr_Soft
;
336 procedure Task_Lock_NT
is
345 procedure Task_Unlock_NT
is
350 -------------------------
351 -- Update_Exception_NT --
352 -------------------------
354 procedure Update_Exception_NT
(X
: EO
:= Current_Target_Exception
) is
356 Ada
.Exceptions
.Save_Occurrence
(NT_TSD
.Current_Excep
, X
);
357 end Update_Exception_NT
;
359 -------------------------
360 -- Package Elaboration --
361 -------------------------
364 NT_TSD
.Exc_Stack_Addr
:= NT_Exc_Stack
(8192)'Address;
365 Ada
.Exceptions
.Save_Occurrence
366 (NT_TSD
.Current_Excep
, Ada
.Exceptions
.Null_Occurrence
);
368 end System
.Soft_Links
;