gcc/ada/s-soflin.adb

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