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-2005 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 pragma Polling (Off);
  35 --  We must turn polling off for this unit, because otherwise we get
  36 --  an infinite loop from the code within the Poll routine itself.
  37
  38 with System.Parameters;
  39 --  Used for Sec_Stack_Ratio
  40
  41 pragma Warnings (Off);
  42 --  Disable warnings since System.Secondary_Stack is currently not
  43 --  Preelaborate
  44 with System.Secondary_Stack;
  45 pragma Warnings (On);
  46
  47 package body System.Soft_Links is
  48
  49    package SST renames System.Secondary_Stack;
  50
  51    NT_Exc_Stack : array (0 .. 8192) of aliased Character;
  52    for NT_Exc_Stack'Alignment use Standard'Maximum_Alignment;
  53    --  Allocate an exception stack for the main program to use.
  54    --  This is currently only used under VMS.
  55
  56    NT_TSD : TSD;
  57    --  Note: we rely on the default initialization of NT_TSD.
  58
  59    --------------------
  60    -- Abort_Defer_NT --
  61    --------------------
  62
  63    procedure Abort_Defer_NT is
  64    begin
  65       null;
  66    end Abort_Defer_NT;
  67
  68    ----------------------
  69    -- Abort_Handler_NT --
  70    ----------------------
  71
  72    procedure Abort_Handler_NT is
  73    begin
  74       null;
  75    end Abort_Handler_NT;
  76
  77    ----------------------
  78    -- Abort_Undefer_NT --
  79    ----------------------
  80
  81    procedure Abort_Undefer_NT is
  82    begin
  83       null;
  84    end Abort_Undefer_NT;
  85
  86    ---------------------------
  87    -- Check_Abort_Status_NT --
  88    ---------------------------
  89
  90    function Check_Abort_Status_NT return Integer is
  91    begin
  92       return Boolean'Pos (False);
  93    end Check_Abort_Status_NT;
  94
  95    ------------------------
  96    -- Complete_Master_NT --
  97    ------------------------
  98
  99    procedure Complete_Master_NT is
 100    begin
 101       null;
 102    end Complete_Master_NT;
 103
 104    ----------------
 105    -- Create_TSD --
 106    ----------------
 107
 108    procedure Create_TSD (New_TSD : in out TSD) is
 109       use type Parameters.Size_Type;
 110
 111       SS_Ratio_Dynamic : constant Boolean :=
 112                            Parameters.Sec_Stack_Ratio = Parameters.Dynamic;
 113
 114    begin
 115       if SS_Ratio_Dynamic then
 116          SST.SS_Init
 117            (New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size);
 118       end if;
 119    end Create_TSD;
 120
 121    -----------------------
 122    -- Current_Master_NT --
 123    -----------------------
 124
 125    function Current_Master_NT return Integer is
 126    begin
 127       return 0;
 128    end Current_Master_NT;
 129
 130    -----------------
 131    -- Destroy_TSD --
 132    -----------------
 133
 134    procedure Destroy_TSD (Old_TSD : in out TSD) is
 135    begin
 136       SST.SS_Free (Old_TSD.Sec_Stack_Addr);
 137    end Destroy_TSD;
 138
 139    ---------------------
 140    -- Enter_Master_NT --
 141    ---------------------
 142
 143    procedure Enter_Master_NT is
 144    begin
 145       null;
 146    end Enter_Master_NT;
 147
 148    --------------------------
 149    -- Get_Current_Excep_NT --
 150    --------------------------
 151
 152    function Get_Current_Excep_NT return EOA is
 153    begin
 154       return NT_TSD.Current_Excep'Access;
 155    end Get_Current_Excep_NT;
 156
 157    ---------------------------
 158    -- Get_Exc_Stack_Addr_NT --
 159    ---------------------------
 160
 161    function Get_Exc_Stack_Addr_NT return Address is
 162    begin
 163       return NT_Exc_Stack (NT_Exc_Stack'Last)'Address;
 164    end Get_Exc_Stack_Addr_NT;
 165
 166    -----------------------------
 167    -- Get_Exc_Stack_Addr_Soft --
 168    -----------------------------
 169
 170    function Get_Exc_Stack_Addr_Soft return Address is
 171    begin
 172       return Get_Exc_Stack_Addr.all;
 173    end Get_Exc_Stack_Addr_Soft;
 174
 175    ------------------------
 176    -- Get_GNAT_Exception --
 177    ------------------------
 178
 179    function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is
 180    begin
 181       return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all);
 182    end Get_GNAT_Exception;
 183
 184    ---------------------------
 185    -- Get_Jmpbuf_Address_NT --
 186    ---------------------------
 187
 188    function Get_Jmpbuf_Address_NT return  Address is
 189    begin
 190       return NT_TSD.Jmpbuf_Address;
 191    end Get_Jmpbuf_Address_NT;
 192
 193    -----------------------------
 194    -- Get_Jmpbuf_Address_Soft --
 195    -----------------------------
 196
 197    function Get_Jmpbuf_Address_Soft return  Address is
 198    begin
 199       return Get_Jmpbuf_Address.all;
 200    end Get_Jmpbuf_Address_Soft;
 201
 202    ---------------------------
 203    -- Get_Sec_Stack_Addr_NT --
 204    ---------------------------
 205
 206    function Get_Sec_Stack_Addr_NT return  Address is
 207    begin
 208       return NT_TSD.Sec_Stack_Addr;
 209    end Get_Sec_Stack_Addr_NT;
 210
 211    -----------------------------
 212    -- Get_Sec_Stack_Addr_Soft --
 213    -----------------------------
 214
 215    function Get_Sec_Stack_Addr_Soft return  Address is
 216    begin
 217       return Get_Sec_Stack_Addr.all;
 218    end Get_Sec_Stack_Addr_Soft;
 219
 220    -----------------------
 221    -- Get_Stack_Info_NT --
 222    -----------------------
 223
 224    function Get_Stack_Info_NT return Stack_Checking.Stack_Access is
 225    begin
 226       return NT_TSD.Pri_Stack_Info'Access;
 227    end Get_Stack_Info_NT;
 228
 229    -------------------
 230    -- Null_Adafinal --
 231    -------------------
 232
 233    procedure Null_Adafinal is
 234    begin
 235       null;
 236    end Null_Adafinal;
 237
 238    ---------------------------
 239    -- Set_Jmpbuf_Address_NT --
 240    ---------------------------
 241
 242    procedure Set_Jmpbuf_Address_NT (Addr : Address) is
 243    begin
 244       NT_TSD.Jmpbuf_Address := Addr;
 245    end Set_Jmpbuf_Address_NT;
 246
 247    procedure Set_Jmpbuf_Address_Soft (Addr : Address) is
 248    begin
 249       Set_Jmpbuf_Address (Addr);
 250    end Set_Jmpbuf_Address_Soft;
 251
 252    ---------------------------
 253    -- Set_Sec_Stack_Addr_NT --
 254    ---------------------------
 255
 256    procedure Set_Sec_Stack_Addr_NT (Addr : Address) is
 257    begin
 258       NT_TSD.Sec_Stack_Addr := Addr;
 259    end Set_Sec_Stack_Addr_NT;
 260
 261    -----------------------------
 262    -- Set_Sec_Stack_Addr_Soft --
 263    -----------------------------
 264
 265    procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is
 266    begin
 267       Set_Sec_Stack_Addr (Addr);
 268    end Set_Sec_Stack_Addr_Soft;
 269
 270    ------------------
 271    -- Task_Lock_NT --
 272    ------------------
 273
 274    procedure Task_Lock_NT is
 275    begin
 276       null;
 277    end Task_Lock_NT;
 278
 279    --------------------
 280    -- Task_Unlock_NT --
 281    --------------------
 282
 283    procedure Task_Unlock_NT is
 284    begin
 285       null;
 286    end Task_Unlock_NT;
 287
 288    -------------------------
 289    -- Update_Exception_NT --
 290    -------------------------
 291
 292    procedure Update_Exception_NT (X : EO := Current_Target_Exception) is
 293    begin
 294       Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X);
 295    end Update_Exception_NT;
 296
 297    ------------------
 298    -- Task_Name_NT --
 299    -------------------
 300
 301    function Task_Name_NT return String is
 302    begin
 303       return "main_task";
 304    end Task_Name_NT;
 305
 306 end System.Soft_Links;