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-2018, 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