Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnat/s-soflin.adb @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
| 68:561a7518be6b | 111:04ced10e8804 |
|---|---|
| 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-2017, 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 | |
| 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; |