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-2005 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
35 -- We must turn polling off for this unit, because otherwise we get
36 -- an infinite loop from the code within the Poll routine itself.
38 with System
.Parameters
;
39 -- Used for Sec_Stack_Ratio
41 pragma Warnings
(Off
);
42 -- Disable warnings since System.Secondary_Stack is currently not
44 with System
.Secondary_Stack
;
47 package body System
.Soft_Links
is
49 package SST
renames System
.Secondary_Stack
;
51 NT_Exc_Stack
: array (0 .. 8192) of aliased Character;
52 for NT_Exc_Stack
'Alignment use Standard
'Maximum_Alignment;
53 -- Allocate an exception stack for the main program to use.
54 -- This is currently only used under VMS.
57 -- Note: we rely on the default initialization of NT_TSD.
63 procedure Abort_Defer_NT
is
68 ----------------------
69 -- Abort_Handler_NT --
70 ----------------------
72 procedure Abort_Handler_NT
is
77 ----------------------
78 -- Abort_Undefer_NT --
79 ----------------------
81 procedure Abort_Undefer_NT
is
86 ---------------------------
87 -- Check_Abort_Status_NT --
88 ---------------------------
90 function Check_Abort_Status_NT
return Integer is
92 return Boolean'Pos (False);
93 end Check_Abort_Status_NT
;
95 ------------------------
96 -- Complete_Master_NT --
97 ------------------------
99 procedure Complete_Master_NT
is
102 end Complete_Master_NT
;
108 procedure Create_TSD
(New_TSD
: in out TSD
) is
109 use type Parameters
.Size_Type
;
111 SS_Ratio_Dynamic
: constant Boolean :=
112 Parameters
.Sec_Stack_Ratio
= Parameters
.Dynamic
;
115 if SS_Ratio_Dynamic
then
117 (New_TSD
.Sec_Stack_Addr
, SST
.Default_Secondary_Stack_Size
);
121 -----------------------
122 -- Current_Master_NT --
123 -----------------------
125 function Current_Master_NT
return Integer is
128 end Current_Master_NT
;
134 procedure Destroy_TSD
(Old_TSD
: in out TSD
) is
136 SST
.SS_Free
(Old_TSD
.Sec_Stack_Addr
);
139 ---------------------
140 -- Enter_Master_NT --
141 ---------------------
143 procedure Enter_Master_NT
is
148 --------------------------
149 -- Get_Current_Excep_NT --
150 --------------------------
152 function Get_Current_Excep_NT
return EOA
is
154 return NT_TSD
.Current_Excep
'Access;
155 end Get_Current_Excep_NT
;
157 ---------------------------
158 -- Get_Exc_Stack_Addr_NT --
159 ---------------------------
161 function Get_Exc_Stack_Addr_NT
return Address
is
163 return NT_Exc_Stack
(NT_Exc_Stack
'Last)'Address;
164 end Get_Exc_Stack_Addr_NT
;
166 -----------------------------
167 -- Get_Exc_Stack_Addr_Soft --
168 -----------------------------
170 function Get_Exc_Stack_Addr_Soft
return Address
is
172 return Get_Exc_Stack_Addr
.all;
173 end Get_Exc_Stack_Addr_Soft
;
175 ------------------------
176 -- Get_GNAT_Exception --
177 ------------------------
179 function Get_GNAT_Exception
return Ada
.Exceptions
.Exception_Id
is
181 return Ada
.Exceptions
.Exception_Identity
(Get_Current_Excep
.all.all);
182 end Get_GNAT_Exception
;
184 ---------------------------
185 -- Get_Jmpbuf_Address_NT --
186 ---------------------------
188 function Get_Jmpbuf_Address_NT
return Address
is
190 return NT_TSD
.Jmpbuf_Address
;
191 end Get_Jmpbuf_Address_NT
;
193 -----------------------------
194 -- Get_Jmpbuf_Address_Soft --
195 -----------------------------
197 function Get_Jmpbuf_Address_Soft
return Address
is
199 return Get_Jmpbuf_Address
.all;
200 end Get_Jmpbuf_Address_Soft
;
202 ---------------------------
203 -- Get_Sec_Stack_Addr_NT --
204 ---------------------------
206 function Get_Sec_Stack_Addr_NT
return Address
is
208 return NT_TSD
.Sec_Stack_Addr
;
209 end Get_Sec_Stack_Addr_NT
;
211 -----------------------------
212 -- Get_Sec_Stack_Addr_Soft --
213 -----------------------------
215 function Get_Sec_Stack_Addr_Soft
return Address
is
217 return Get_Sec_Stack_Addr
.all;
218 end Get_Sec_Stack_Addr_Soft
;
220 -----------------------
221 -- Get_Stack_Info_NT --
222 -----------------------
224 function Get_Stack_Info_NT
return Stack_Checking
.Stack_Access
is
226 return NT_TSD
.Pri_Stack_Info
'Access;
227 end Get_Stack_Info_NT
;
233 procedure Null_Adafinal
is
238 ---------------------------
239 -- Set_Jmpbuf_Address_NT --
240 ---------------------------
242 procedure Set_Jmpbuf_Address_NT
(Addr
: Address
) is
244 NT_TSD
.Jmpbuf_Address
:= Addr
;
245 end Set_Jmpbuf_Address_NT
;
247 procedure Set_Jmpbuf_Address_Soft
(Addr
: Address
) is
249 Set_Jmpbuf_Address
(Addr
);
250 end Set_Jmpbuf_Address_Soft
;
252 ---------------------------
253 -- Set_Sec_Stack_Addr_NT --
254 ---------------------------
256 procedure Set_Sec_Stack_Addr_NT
(Addr
: Address
) is
258 NT_TSD
.Sec_Stack_Addr
:= Addr
;
259 end Set_Sec_Stack_Addr_NT
;
261 -----------------------------
262 -- Set_Sec_Stack_Addr_Soft --
263 -----------------------------
265 procedure Set_Sec_Stack_Addr_Soft
(Addr
: Address
) is
267 Set_Sec_Stack_Addr
(Addr
);
268 end Set_Sec_Stack_Addr_Soft
;
274 procedure Task_Lock_NT
is
283 procedure Task_Unlock_NT
is
288 -------------------------
289 -- Update_Exception_NT --
290 -------------------------
292 procedure Update_Exception_NT
(X
: EO
:= Current_Target_Exception
) is
294 Ada
.Exceptions
.Save_Occurrence
(NT_TSD
.Current_Excep
, X
);
295 end Update_Exception_NT
;
301 function Task_Name_NT
return String is
306 end System
.Soft_Links
;