Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/libgnat/s-soflin.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/ada/libgnat/s-soflin.adb Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,307 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S O F T _ L I N K S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get an +-- infinite loop from the code within the Poll routine itself. + +pragma Warnings (Off); +-- Disable warnings as System.Soft_Links.Initialize is not Preelaborate. It is +-- safe to with this unit as its elaboration routine will only be initializing +-- NT_TSD, which is part of this package spec. +with System.Soft_Links.Initialize; +pragma Warnings (On); + +package body System.Soft_Links is + + Stack_Limit : aliased System.Address := System.Null_Address; + pragma Export (C, Stack_Limit, "__gnat_stack_limit"); + -- Needed for Vx6Cert (Vx653mc) GOS cert and ravenscar-cert runtimes, + -- VxMILS cert, ravenscar-cert and full runtimes, Vx 5 default runtime + + -------------------- + -- Abort_Defer_NT -- + -------------------- + + procedure Abort_Defer_NT is + begin + null; + end Abort_Defer_NT; + + ---------------------- + -- Abort_Handler_NT -- + ---------------------- + + procedure Abort_Handler_NT is + begin + null; + end Abort_Handler_NT; + + ---------------------- + -- Abort_Undefer_NT -- + ---------------------- + + procedure Abort_Undefer_NT is + begin + null; + end Abort_Undefer_NT; + + ----------------- + -- Adafinal_NT -- + ----------------- + + procedure Adafinal_NT is + begin + -- Handle normal task termination by the environment task, but only + -- for the normal task termination. In the case of Abnormal and + -- Unhandled_Exception they must have been handled before, and the + -- task termination soft link must have been changed so the task + -- termination routine is not executed twice. + + Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence); + + -- Finalize all library-level controlled objects if needed + + if Finalize_Library_Objects /= null then + Finalize_Library_Objects.all; + end if; + end Adafinal_NT; + + --------------------------- + -- Check_Abort_Status_NT -- + --------------------------- + + function Check_Abort_Status_NT return Integer is + begin + return Boolean'Pos (False); + end Check_Abort_Status_NT; + + ------------------------ + -- Complete_Master_NT -- + ------------------------ + + procedure Complete_Master_NT is + begin + null; + end Complete_Master_NT; + + ---------------- + -- Create_TSD -- + ---------------- + + procedure Create_TSD + (New_TSD : in out TSD; + Sec_Stack : SST.SS_Stack_Ptr; + Sec_Stack_Size : System.Parameters.Size_Type) + is + begin + New_TSD.Jmpbuf_Address := Null_Address; + + New_TSD.Sec_Stack_Ptr := Sec_Stack; + SST.SS_Init (New_TSD.Sec_Stack_Ptr, Sec_Stack_Size); + end Create_TSD; + + ----------------------- + -- Current_Master_NT -- + ----------------------- + + function Current_Master_NT return Integer is + begin + return 0; + end Current_Master_NT; + + ----------------- + -- Destroy_TSD -- + ----------------- + + procedure Destroy_TSD (Old_TSD : in out TSD) is + begin + SST.SS_Free (Old_TSD.Sec_Stack_Ptr); + end Destroy_TSD; + + --------------------- + -- Enter_Master_NT -- + --------------------- + + procedure Enter_Master_NT is + begin + null; + end Enter_Master_NT; + + -------------------------- + -- Get_Current_Excep_NT -- + -------------------------- + + function Get_Current_Excep_NT return EOA is + begin + return NT_TSD.Current_Excep'Access; + end Get_Current_Excep_NT; + + ------------------------ + -- Get_GNAT_Exception -- + ------------------------ + + function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is + begin + return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all); + end Get_GNAT_Exception; + + --------------------------- + -- Get_Jmpbuf_Address_NT -- + --------------------------- + + function Get_Jmpbuf_Address_NT return Address is + begin + return NT_TSD.Jmpbuf_Address; + end Get_Jmpbuf_Address_NT; + + ----------------------------- + -- Get_Jmpbuf_Address_Soft -- + ----------------------------- + + function Get_Jmpbuf_Address_Soft return Address is + begin + return Get_Jmpbuf_Address.all; + end Get_Jmpbuf_Address_Soft; + + ---------------------- + -- Get_Sec_Stack_NT -- + ---------------------- + + function Get_Sec_Stack_NT return SST.SS_Stack_Ptr is + begin + return NT_TSD.Sec_Stack_Ptr; + end Get_Sec_Stack_NT; + + ----------------------------- + -- Get_Sec_Stack_Soft -- + ----------------------------- + + function Get_Sec_Stack_Soft return SST.SS_Stack_Ptr is + begin + return Get_Sec_Stack.all; + end Get_Sec_Stack_Soft; + + ----------------------- + -- Get_Stack_Info_NT -- + ----------------------- + + function Get_Stack_Info_NT return Stack_Checking.Stack_Access is + begin + return NT_TSD.Pri_Stack_Info'Access; + end Get_Stack_Info_NT; + + ----------------------------- + -- Save_Library_Occurrence -- + ----------------------------- + + procedure Save_Library_Occurrence (E : EOA) is + use Ada.Exceptions; + begin + if not Library_Exception_Set then + Library_Exception_Set := True; + if E /= null then + Ada.Exceptions.Save_Occurrence (Library_Exception, E.all); + end if; + end if; + end Save_Library_Occurrence; + + --------------------------- + -- Set_Jmpbuf_Address_NT -- + --------------------------- + + procedure Set_Jmpbuf_Address_NT (Addr : Address) is + begin + NT_TSD.Jmpbuf_Address := Addr; + end Set_Jmpbuf_Address_NT; + + procedure Set_Jmpbuf_Address_Soft (Addr : Address) is + begin + Set_Jmpbuf_Address (Addr); + end Set_Jmpbuf_Address_Soft; + + ---------------------- + -- Set_Sec_Stack_NT -- + ---------------------- + + procedure Set_Sec_Stack_NT (Stack : SST.SS_Stack_Ptr) is + begin + NT_TSD.Sec_Stack_Ptr := Stack; + end Set_Sec_Stack_NT; + + ------------------------ + -- Set_Sec_Stack_Soft -- + ------------------------ + + procedure Set_Sec_Stack_Soft (Stack : SST.SS_Stack_Ptr) is + begin + Set_Sec_Stack (Stack); + end Set_Sec_Stack_Soft; + + ------------------ + -- Task_Lock_NT -- + ------------------ + + procedure Task_Lock_NT is + begin + null; + end Task_Lock_NT; + + ------------------ + -- Task_Name_NT -- + ------------------- + + function Task_Name_NT return String is + begin + return "main_task"; + end Task_Name_NT; + + ------------------------- + -- Task_Termination_NT -- + ------------------------- + + procedure Task_Termination_NT (Excep : EO) is + pragma Unreferenced (Excep); + begin + null; + end Task_Termination_NT; + + -------------------- + -- Task_Unlock_NT -- + -------------------- + + procedure Task_Unlock_NT is + begin + null; + end Task_Unlock_NT; +end System.Soft_Links;