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-2015, 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 38with System.Parameters; 39 40pragma Warnings (Off); 41-- Disable warnings since System.Secondary_Stack is currently not Preelaborate 42with System.Secondary_Stack; 43pragma Warnings (On); 44 45package 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; 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 312end System.Soft_Links; 313