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