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-2019, 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-- 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
32pragma Compiler_Unit_Warning;
33
34pragma 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
38pragma 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.
42with System.Soft_Links.Initialize;
43pragma Warnings (On);
44
45package 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;
307end System.Soft_Links;
308