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-2009, 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_Exc_Stack : array (0 .. 8192) of aliased Character;
  50    for NT_Exc_Stack'Alignment use Standard'Maximum_Alignment;
  51    --  Allocate an exception stack for the main program to use.
  52    --  This is currently only used under VMS.
  53
  54    NT_TSD : TSD;
  55    --  Note: we rely on the default initialization of NT_TSD
  56
  57    --------------------
  58    -- Abort_Defer_NT --
  59    --------------------
  60
  61    procedure Abort_Defer_NT is
  62    begin
  63       null;
  64    end Abort_Defer_NT;
  65
  66    ----------------------
  67    -- Abort_Handler_NT --
  68    ----------------------
  69
  70    procedure Abort_Handler_NT is
  71    begin
  72       null;
  73    end Abort_Handler_NT;
  74
  75    ----------------------
  76    -- Abort_Undefer_NT --
  77    ----------------------
  78
  79    procedure Abort_Undefer_NT is
  80    begin
  81       null;
  82    end Abort_Undefer_NT;
  83
  84    -----------------
  85    -- Adafinal_NT --
  86    -----------------
  87
  88    procedure Adafinal_NT is
  89    begin
  90       --  Handle normal task termination by the environment task, but only
  91       --  for the normal task termination. In the case of Abnormal and
  92       --  Unhandled_Exception they must have been handled before, and the
  93       --  task termination soft link must have been changed so the task
  94       --  termination routine is not executed twice.
  95
  96       Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
  97
  98       --  Finalize the global list for controlled objects if needed
  99
 100       Finalize_Global_List.all;
 101    end Adafinal_NT;
 102
 103    ---------------------------
 104    -- Check_Abort_Status_NT --
 105    ---------------------------
 106
 107    function Check_Abort_Status_NT return Integer is
 108    begin
 109       return Boolean'Pos (False);
 110    end Check_Abort_Status_NT;
 111
 112    ------------------------
 113    -- Complete_Master_NT --
 114    ------------------------
 115
 116    procedure Complete_Master_NT is
 117    begin
 118       null;
 119    end Complete_Master_NT;
 120
 121    ----------------
 122    -- Create_TSD --
 123    ----------------
 124
 125    procedure Create_TSD (New_TSD : in out TSD) is
 126       use type Parameters.Size_Type;
 127
 128       SS_Ratio_Dynamic : constant Boolean :=
 129                            Parameters.Sec_Stack_Ratio = Parameters.Dynamic;
 130
 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_Exc_Stack_Addr_NT --
 176    ---------------------------
 177
 178    function Get_Exc_Stack_Addr_NT return Address is
 179    begin
 180       return NT_Exc_Stack (NT_Exc_Stack'Last)'Address;
 181    end Get_Exc_Stack_Addr_NT;
 182
 183    -----------------------------
 184    -- Get_Exc_Stack_Addr_Soft --
 185    -----------------------------
 186
 187    function Get_Exc_Stack_Addr_Soft return Address is
 188    begin
 189       return Get_Exc_Stack_Addr.all;
 190    end Get_Exc_Stack_Addr_Soft;
 191
 192    ------------------------
 193    -- Get_GNAT_Exception --
 194    ------------------------
 195
 196    function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is
 197    begin
 198       return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all);
 199    end Get_GNAT_Exception;
 200
 201    ---------------------------
 202    -- Get_Jmpbuf_Address_NT --
 203    ---------------------------
 204
 205    function Get_Jmpbuf_Address_NT return  Address is
 206    begin
 207       return NT_TSD.Jmpbuf_Address;
 208    end Get_Jmpbuf_Address_NT;
 209
 210    -----------------------------
 211    -- Get_Jmpbuf_Address_Soft --
 212    -----------------------------
 213
 214    function Get_Jmpbuf_Address_Soft return  Address is
 215    begin
 216       return Get_Jmpbuf_Address.all;
 217    end Get_Jmpbuf_Address_Soft;
 218
 219    ---------------------------
 220    -- Get_Sec_Stack_Addr_NT --
 221    ---------------------------
 222
 223    function Get_Sec_Stack_Addr_NT return  Address is
 224    begin
 225       return NT_TSD.Sec_Stack_Addr;
 226    end Get_Sec_Stack_Addr_NT;
 227
 228    -----------------------------
 229    -- Get_Sec_Stack_Addr_Soft --
 230    -----------------------------
 231
 232    function Get_Sec_Stack_Addr_Soft return  Address is
 233    begin
 234       return Get_Sec_Stack_Addr.all;
 235    end Get_Sec_Stack_Addr_Soft;
 236
 237    -----------------------
 238    -- Get_Stack_Info_NT --
 239    -----------------------
 240
 241    function Get_Stack_Info_NT return Stack_Checking.Stack_Access is
 242    begin
 243       return NT_TSD.Pri_Stack_Info'Access;
 244    end Get_Stack_Info_NT;
 245
 246    -------------------------------
 247    -- Null_Finalize_Global_List --
 248    -------------------------------
 249
 250    procedure Null_Finalize_Global_List is
 251    begin
 252       null;
 253    end Null_Finalize_Global_List;
 254
 255    ---------------------------
 256    -- Set_Jmpbuf_Address_NT --
 257    ---------------------------
 258
 259    procedure Set_Jmpbuf_Address_NT (Addr : Address) is
 260    begin
 261       NT_TSD.Jmpbuf_Address := Addr;
 262    end Set_Jmpbuf_Address_NT;
 263
 264    procedure Set_Jmpbuf_Address_Soft (Addr : Address) is
 265    begin
 266       Set_Jmpbuf_Address (Addr);
 267    end Set_Jmpbuf_Address_Soft;
 268
 269    ---------------------------
 270    -- Set_Sec_Stack_Addr_NT --
 271    ---------------------------
 272
 273    procedure Set_Sec_Stack_Addr_NT (Addr : Address) is
 274    begin
 275       NT_TSD.Sec_Stack_Addr := Addr;
 276    end Set_Sec_Stack_Addr_NT;
 277
 278    -----------------------------
 279    -- Set_Sec_Stack_Addr_Soft --
 280    -----------------------------
 281
 282    procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is
 283    begin
 284       Set_Sec_Stack_Addr (Addr);
 285    end Set_Sec_Stack_Addr_Soft;
 286
 287    ------------------
 288    -- Task_Lock_NT --
 289    ------------------
 290
 291    procedure Task_Lock_NT is
 292    begin
 293       null;
 294    end Task_Lock_NT;
 295
 296    ------------------
 297    -- Task_Name_NT --
 298    -------------------
 299
 300    function Task_Name_NT return String is
 301    begin
 302       return "main_task";
 303    end Task_Name_NT;
 304
 305    -------------------------
 306    -- Task_Termination_NT --
 307    -------------------------
 308
 309    procedure Task_Termination_NT (Excep : EO) is
 310       pragma Unreferenced (Excep);
 311    begin
 312       null;
 313    end Task_Termination_NT;
 314
 315    --------------------
 316    -- Task_Unlock_NT --
 317    --------------------
 318
 319    procedure Task_Unlock_NT is
 320    begin
 321       null;
 322    end Task_Unlock_NT;
 323
 324    -------------------------
 325    -- Update_Exception_NT --
 326    -------------------------
 327
 328    procedure Update_Exception_NT (X : EO := Current_Target_Exception) is
 329    begin
 330       Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X);
 331    end Update_Exception_NT;
 332
 333 end System.Soft_Links;