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-2012, 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;
  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    --------------------
  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 (New_TSD : in out TSD) is
 123       use Parameters;
 124       SS_Ratio_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic;
 125    begin
 126       if SS_Ratio_Dynamic then
 127          SST.SS_Init
 128            (New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size);
 129       end if;
 130    end Create_TSD;
 131
 132    -----------------------
 133    -- Current_Master_NT --
 134    -----------------------
 135
 136    function Current_Master_NT return Integer is
 137    begin
 138       return 0;
 139    end Current_Master_NT;
 140
 141    -----------------
 142    -- Destroy_TSD --
 143    -----------------
 144
 145    procedure Destroy_TSD (Old_TSD : in out TSD) is
 146    begin
 147       SST.SS_Free (Old_TSD.Sec_Stack_Addr);
 148    end Destroy_TSD;
 149
 150    ---------------------
 151    -- Enter_Master_NT --
 152    ---------------------
 153
 154    procedure Enter_Master_NT is
 155    begin
 156       null;
 157    end Enter_Master_NT;
 158
 159    --------------------------
 160    -- Get_Current_Excep_NT --
 161    --------------------------
 162
 163    function Get_Current_Excep_NT return EOA is
 164    begin
 165       return NT_TSD.Current_Excep'Access;
 166    end Get_Current_Excep_NT;
 167
 168    ------------------------
 169    -- Get_GNAT_Exception --
 170    ------------------------
 171
 172    function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is
 173    begin
 174       return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all);
 175    end Get_GNAT_Exception;
 176
 177    ---------------------------
 178    -- Get_Jmpbuf_Address_NT --
 179    ---------------------------
 180
 181    function Get_Jmpbuf_Address_NT return  Address is
 182    begin
 183       return NT_TSD.Jmpbuf_Address;
 184    end Get_Jmpbuf_Address_NT;
 185
 186    -----------------------------
 187    -- Get_Jmpbuf_Address_Soft --
 188    -----------------------------
 189
 190    function Get_Jmpbuf_Address_Soft return  Address is
 191    begin
 192       return Get_Jmpbuf_Address.all;
 193    end Get_Jmpbuf_Address_Soft;
 194
 195    ---------------------------
 196    -- Get_Sec_Stack_Addr_NT --
 197    ---------------------------
 198
 199    function Get_Sec_Stack_Addr_NT return  Address is
 200    begin
 201       return NT_TSD.Sec_Stack_Addr;
 202    end Get_Sec_Stack_Addr_NT;
 203
 204    -----------------------------
 205    -- Get_Sec_Stack_Addr_Soft --
 206    -----------------------------
 207
 208    function Get_Sec_Stack_Addr_Soft return  Address is
 209    begin
 210       return Get_Sec_Stack_Addr.all;
 211    end Get_Sec_Stack_Addr_Soft;
 212
 213    -----------------------
 214    -- Get_Stack_Info_NT --
 215    -----------------------
 216
 217    function Get_Stack_Info_NT return Stack_Checking.Stack_Access is
 218    begin
 219       return NT_TSD.Pri_Stack_Info'Access;
 220    end Get_Stack_Info_NT;
 221
 222    -----------------------------
 223    -- Save_Library_Occurrence --
 224    -----------------------------
 225
 226    procedure Save_Library_Occurrence (E : EOA) is
 227       use Ada.Exceptions;
 228    begin
 229       if not Library_Exception_Set then
 230          Library_Exception_Set := True;
 231          if E /= null then
 232             Ada.Exceptions.Save_Occurrence (Library_Exception, E.all);
 233          end if;
 234       end if;
 235    end Save_Library_Occurrence;
 236
 237    ---------------------------
 238    -- Set_Jmpbuf_Address_NT --
 239    ---------------------------
 240
 241    procedure Set_Jmpbuf_Address_NT (Addr : Address) is
 242    begin
 243       NT_TSD.Jmpbuf_Address := Addr;
 244    end Set_Jmpbuf_Address_NT;
 245
 246    procedure Set_Jmpbuf_Address_Soft (Addr : Address) is
 247    begin
 248       Set_Jmpbuf_Address (Addr);
 249    end Set_Jmpbuf_Address_Soft;
 250
 251    ---------------------------
 252    -- Set_Sec_Stack_Addr_NT --
 253    ---------------------------
 254
 255    procedure Set_Sec_Stack_Addr_NT (Addr : Address) is
 256    begin
 257       NT_TSD.Sec_Stack_Addr := Addr;
 258    end Set_Sec_Stack_Addr_NT;
 259
 260    -----------------------------
 261    -- Set_Sec_Stack_Addr_Soft --
 262    -----------------------------
 263
 264    procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is
 265    begin
 266       Set_Sec_Stack_Addr (Addr);
 267    end Set_Sec_Stack_Addr_Soft;
 268
 269    ------------------
 270    -- Task_Lock_NT --
 271    ------------------
 272
 273    procedure Task_Lock_NT is
 274    begin
 275       null;
 276    end Task_Lock_NT;
 277
 278    ------------------
 279    -- Task_Name_NT --
 280    -------------------
 281
 282    function Task_Name_NT return String is
 283    begin
 284       return "main_task";
 285    end Task_Name_NT;
 286
 287    -------------------------
 288    -- Task_Termination_NT --
 289    -------------------------
 290
 291    procedure Task_Termination_NT (Excep : EO) is
 292       pragma Unreferenced (Excep);
 293    begin
 294       null;
 295    end Task_Termination_NT;
 296
 297    --------------------
 298    -- Task_Unlock_NT --
 299    --------------------
 300
 301    procedure Task_Unlock_NT is
 302    begin
 303       null;
 304    end Task_Unlock_NT;
 305
 306    -------------------------
 307    -- Update_Exception_NT --
 308    -------------------------
 309
 310    procedure Update_Exception_NT (X : EO := Current_Target_Exception) is
 311    begin
 312       Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X);
 313    end Update_Exception_NT;
 314
 315 end System.Soft_Links;