File : s-soflin.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S Y S T E M . S O F T _ L I N K S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, 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 -- --
19 -- --
20 -- --
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
32 pragma Compiler_Unit_Warning;
33
34 pragma Polling (Off);
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.
37
38 with System.Parameters;
39
40 pragma Warnings (Off);
41 -- Disable warnings since System.Secondary_Stack is currently not Preelaborate
42 with System.Secondary_Stack;
43 pragma Warnings (On);
44
45 package body System.Soft_Links is
46
47 package SST renames System.Secondary_Stack;
48
49 NT_TSD : TSD;
50 -- Note: we rely on the default initialization of NT_TSD
51
52 -- Needed for Vx6Cert (Vx653mc) GOS cert and ravenscar-cert runtimes,
53 -- VxMILS cert, ravenscar-cert and full runtimes, Vx 5 default runtime
54 Stack_Limit : aliased System.Address := System.Null_Address;
55
56 pragma Export (C, Stack_Limit, "__gnat_stack_limit");
57
58 --------------------
59 -- Abort_Defer_NT --
60 --------------------
61
62 procedure Abort_Defer_NT is
63 begin
64 null;
65 end Abort_Defer_NT;
66
67 ----------------------
68 -- Abort_Handler_NT --
69 ----------------------
70
71 procedure Abort_Handler_NT is
72 begin
73 null;
74 end Abort_Handler_NT;
75
76 ----------------------
77 -- Abort_Undefer_NT --
78 ----------------------
79
80 procedure Abort_Undefer_NT is
81 begin
82 null;
83 end Abort_Undefer_NT;
84
85 -----------------
86 -- Adafinal_NT --
87 -----------------
88
89 procedure Adafinal_NT is
90 begin
91 -- Handle normal task termination by the environment task, but only
92 -- for the normal task termination. In the case of Abnormal and
93 -- Unhandled_Exception they must have been handled before, and the
94 -- task termination soft link must have been changed so the task
95 -- termination routine is not executed twice.
96
97 Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
98
99 -- Finalize all library-level controlled objects if needed
100
101 if Finalize_Library_Objects /= null then
102 Finalize_Library_Objects.all;
103 end if;
104 end Adafinal_NT;
105
106 ---------------------------
107 -- Check_Abort_Status_NT --
108 ---------------------------
109
110 function Check_Abort_Status_NT return Integer is
111 begin
112 return Boolean'Pos (False);
113 end Check_Abort_Status_NT;
114
115 ------------------------
116 -- Complete_Master_NT --
117 ------------------------
118
119 procedure Complete_Master_NT is
120 begin
121 null;
122 end Complete_Master_NT;
123
124 ----------------
125 -- Create_TSD --
126 ----------------
127
128 procedure Create_TSD (New_TSD : in out TSD) is
129 use Parameters;
130 SS_Ratio_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic;
131 begin
132 if SS_Ratio_Dynamic then
133 SST.SS_Init
134 (New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size);
135 end if;
136 end Create_TSD;
137
138 -----------------------
139 -- Current_Master_NT --
140 -----------------------
141
142 function Current_Master_NT return Integer is
143 begin
144 return 0;
145 end Current_Master_NT;
146
147 -----------------
148 -- Destroy_TSD --
149 -----------------
150
151 procedure Destroy_TSD (Old_TSD : in out TSD) is
152 begin
153 SST.SS_Free (Old_TSD.Sec_Stack_Addr);
154 end Destroy_TSD;
155
156 ---------------------
157 -- Enter_Master_NT --
158 ---------------------
159
160 procedure Enter_Master_NT is
161 begin
162 null;
163 end Enter_Master_NT;
164
165 --------------------------
166 -- Get_Current_Excep_NT --
167 --------------------------
168
169 function Get_Current_Excep_NT return EOA is
170 begin
171 return NT_TSD.Current_Excep'Access;
172 end Get_Current_Excep_NT;
173
174 ------------------------
175 -- Get_GNAT_Exception --
176 ------------------------
177
178 function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is
179 begin
180 return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all);
181 end Get_GNAT_Exception;
182
183 ---------------------------
184 -- Get_Jmpbuf_Address_NT --
185 ---------------------------
186
187 function Get_Jmpbuf_Address_NT return Address is
188 begin
189 return NT_TSD.Jmpbuf_Address;
190 end Get_Jmpbuf_Address_NT;
191
192 -----------------------------
193 -- Get_Jmpbuf_Address_Soft --
194 -----------------------------
195
196 function Get_Jmpbuf_Address_Soft return Address is
197 begin
198 return Get_Jmpbuf_Address.all;
199 end Get_Jmpbuf_Address_Soft;
200
201 ---------------------------
202 -- Get_Sec_Stack_Addr_NT --
203 ---------------------------
204
205 function Get_Sec_Stack_Addr_NT return Address is
206 begin
207 return NT_TSD.Sec_Stack_Addr;
208 end Get_Sec_Stack_Addr_NT;
209
210 -----------------------------
211 -- Get_Sec_Stack_Addr_Soft --
212 -----------------------------
213
214 function Get_Sec_Stack_Addr_Soft return Address is
215 begin
216 return Get_Sec_Stack_Addr.all;
217 end Get_Sec_Stack_Addr_Soft;
218
219 -----------------------
220 -- Get_Stack_Info_NT --
221 -----------------------
222
223 function Get_Stack_Info_NT return Stack_Checking.Stack_Access is
224 begin
225 return NT_TSD.Pri_Stack_Info'Access;
226 end Get_Stack_Info_NT;
227
228 -----------------------------
229 -- Save_Library_Occurrence --
230 -----------------------------
231
232 procedure Save_Library_Occurrence (E : EOA) is
233 use Ada.Exceptions;
234 begin
235 if not Library_Exception_Set then
236 Library_Exception_Set := True;
237 if E /= null then
238 Ada.Exceptions.Save_Occurrence (Library_Exception, E.all);
239 end if;
240 end if;
241 end Save_Library_Occurrence;
242
243 ---------------------------
244 -- Set_Jmpbuf_Address_NT --
245 ---------------------------
246
247 procedure Set_Jmpbuf_Address_NT (Addr : Address) is
248 begin
249 NT_TSD.Jmpbuf_Address := Addr;
250 end Set_Jmpbuf_Address_NT;
251
252 procedure Set_Jmpbuf_Address_Soft (Addr : Address) is
253 begin
254 Set_Jmpbuf_Address (Addr);
255 end Set_Jmpbuf_Address_Soft;
256
257 ---------------------------
258 -- Set_Sec_Stack_Addr_NT --
259 ---------------------------
260
261 procedure Set_Sec_Stack_Addr_NT (Addr : Address) is
262 begin
263 NT_TSD.Sec_Stack_Addr := Addr;
264 end Set_Sec_Stack_Addr_NT;
265
266 -----------------------------
267 -- Set_Sec_Stack_Addr_Soft --
268 -----------------------------
269
270 procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is
271 begin
272 Set_Sec_Stack_Addr (Addr);
273 end Set_Sec_Stack_Addr_Soft;
274
275 ------------------
276 -- Task_Lock_NT --
277 ------------------
278
279 procedure Task_Lock_NT is
280 begin
281 null;
282 end Task_Lock_NT;
283
284 ------------------
285 -- Task_Name_NT --
286 -------------------
287
288 function Task_Name_NT return String is
289 begin
290 return "main_task";
291 end Task_Name_NT;
292
293 -------------------------
294 -- Task_Termination_NT --
295 -------------------------
296
297 procedure Task_Termination_NT (Excep : EO) is
298 pragma Unreferenced (Excep);
299 begin
300 null;
301 end Task_Termination_NT;
302
303 --------------------
304 -- Task_Unlock_NT --
305 --------------------
306
307 procedure Task_Unlock_NT is
308 begin
309 null;
310 end Task_Unlock_NT;
311
312 end System.Soft_Links;