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-2006, 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    -- Adafinal_NT --
  88    -----------------
  89
  90    procedure Adafinal_NT is
  91    begin
  92       --  Handle normal task termination by the environment task, but only
  93       --  for the normal task termination. In the case of Abnormal and
  94       --  Unhandled_Exception they must have been handled before, and the
  95       --  task termination soft link must have been changed so the task
  96       --  termination routine is not executed twice.
  97
  98       Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
  99
 100       --  Finalize the global list for controlled objects if needed
 101
 102       Finalize_Global_List.all;
 103    end Adafinal_NT;
 104
 105    ---------------------------
 106    -- Check_Abort_Status_NT --
 107    ---------------------------
 108
 109    function Check_Abort_Status_NT return Integer is
 110    begin
 111       return Boolean'Pos (False);
 112    end Check_Abort_Status_NT;
 113
 114    ------------------------
 115    -- Complete_Master_NT --
 116    ------------------------
 117
 118    procedure Complete_Master_NT is
 119    begin
 120       null;
 121    end Complete_Master_NT;
 122
 123    ----------------
 124    -- Create_TSD --
 125    ----------------
 126
 127    procedure Create_TSD (New_TSD : in out TSD) is
 128       use type Parameters.Size_Type;
 129
 130       SS_Ratio_Dynamic : constant Boolean :=
 131                            Parameters.Sec_Stack_Ratio = Parameters.Dynamic;
 132
 133    begin
 134       if SS_Ratio_Dynamic then
 135          SST.SS_Init
 136            (New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size);
 137       end if;
 138    end Create_TSD;
 139
 140    -----------------------
 141    -- Current_Master_NT --
 142    -----------------------
 143
 144    function Current_Master_NT return Integer is
 145    begin
 146       return 0;
 147    end Current_Master_NT;
 148
 149    -----------------
 150    -- Destroy_TSD --
 151    -----------------
 152
 153    procedure Destroy_TSD (Old_TSD : in out TSD) is
 154    begin
 155       SST.SS_Free (Old_TSD.Sec_Stack_Addr);
 156    end Destroy_TSD;
 157
 158    ---------------------
 159    -- Enter_Master_NT --
 160    ---------------------
 161
 162    procedure Enter_Master_NT is
 163    begin
 164       null;
 165    end Enter_Master_NT;
 166
 167    --------------------------
 168    -- Get_Current_Excep_NT --
 169    --------------------------
 170
 171    function Get_Current_Excep_NT return EOA is
 172    begin
 173       return NT_TSD.Current_Excep'Access;
 174    end Get_Current_Excep_NT;
 175
 176    ---------------------------
 177    -- Get_Exc_Stack_Addr_NT --
 178    ---------------------------
 179
 180    function Get_Exc_Stack_Addr_NT return Address is
 181    begin
 182       return NT_Exc_Stack (NT_Exc_Stack'Last)'Address;
 183    end Get_Exc_Stack_Addr_NT;
 184
 185    -----------------------------
 186    -- Get_Exc_Stack_Addr_Soft --
 187    -----------------------------
 188
 189    function Get_Exc_Stack_Addr_Soft return Address is
 190    begin
 191       return Get_Exc_Stack_Addr.all;
 192    end Get_Exc_Stack_Addr_Soft;
 193
 194    ------------------------
 195    -- Get_GNAT_Exception --
 196    ------------------------
 197
 198    function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is
 199    begin
 200       return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all);
 201    end Get_GNAT_Exception;
 202
 203    ---------------------------
 204    -- Get_Jmpbuf_Address_NT --
 205    ---------------------------
 206
 207    function Get_Jmpbuf_Address_NT return  Address is
 208    begin
 209       return NT_TSD.Jmpbuf_Address;
 210    end Get_Jmpbuf_Address_NT;
 211
 212    -----------------------------
 213    -- Get_Jmpbuf_Address_Soft --
 214    -----------------------------
 215
 216    function Get_Jmpbuf_Address_Soft return  Address is
 217    begin
 218       return Get_Jmpbuf_Address.all;
 219    end Get_Jmpbuf_Address_Soft;
 220
 221    ---------------------------
 222    -- Get_Sec_Stack_Addr_NT --
 223    ---------------------------
 224
 225    function Get_Sec_Stack_Addr_NT return  Address is
 226    begin
 227       return NT_TSD.Sec_Stack_Addr;
 228    end Get_Sec_Stack_Addr_NT;
 229
 230    -----------------------------
 231    -- Get_Sec_Stack_Addr_Soft --
 232    -----------------------------
 233
 234    function Get_Sec_Stack_Addr_Soft return  Address is
 235    begin
 236       return Get_Sec_Stack_Addr.all;
 237    end Get_Sec_Stack_Addr_Soft;
 238
 239    -----------------------
 240    -- Get_Stack_Info_NT --
 241    -----------------------
 242
 243    function Get_Stack_Info_NT return Stack_Checking.Stack_Access is
 244    begin
 245       return NT_TSD.Pri_Stack_Info'Access;
 246    end Get_Stack_Info_NT;
 247
 248    -------------------------------
 249    -- Null_Finalize_Global_List --
 250    -------------------------------
 251
 252    procedure Null_Finalize_Global_List is
 253    begin
 254       null;
 255    end Null_Finalize_Global_List;
 256
 257    ---------------------------
 258    -- Set_Jmpbuf_Address_NT --
 259    ---------------------------
 260
 261    procedure Set_Jmpbuf_Address_NT (Addr : Address) is
 262    begin
 263       NT_TSD.Jmpbuf_Address := Addr;
 264    end Set_Jmpbuf_Address_NT;
 265
 266    procedure Set_Jmpbuf_Address_Soft (Addr : Address) is
 267    begin
 268       Set_Jmpbuf_Address (Addr);
 269    end Set_Jmpbuf_Address_Soft;
 270
 271    ---------------------------
 272    -- Set_Sec_Stack_Addr_NT --
 273    ---------------------------
 274
 275    procedure Set_Sec_Stack_Addr_NT (Addr : Address) is
 276    begin
 277       NT_TSD.Sec_Stack_Addr := Addr;
 278    end Set_Sec_Stack_Addr_NT;
 279
 280    -----------------------------
 281    -- Set_Sec_Stack_Addr_Soft --
 282    -----------------------------
 283
 284    procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is
 285    begin
 286       Set_Sec_Stack_Addr (Addr);
 287    end Set_Sec_Stack_Addr_Soft;
 288
 289    ------------------
 290    -- Task_Lock_NT --
 291    ------------------
 292
 293    procedure Task_Lock_NT is
 294    begin
 295       null;
 296    end Task_Lock_NT;
 297
 298    ------------------
 299    -- Task_Name_NT --
 300    -------------------
 301
 302    function Task_Name_NT return String is
 303    begin
 304       return "main_task";
 305    end Task_Name_NT;
 306
 307    -------------------------
 308    -- Task_Termination_NT --
 309    -------------------------
 310
 311    procedure Task_Termination_NT (Excep : EO) is
 312       pragma Warnings (Off, Excep);
 313    begin
 314       null;
 315    end Task_Termination_NT;
 316
 317    --------------------
 318    -- Task_Unlock_NT --
 319    --------------------
 320
 321    procedure Task_Unlock_NT is
 322    begin
 323       null;
 324    end Task_Unlock_NT;
 325
 326    -------------------------
 327    -- Update_Exception_NT --
 328    -------------------------
 329
 330    procedure Update_Exception_NT (X : EO := Current_Target_Exception) is
 331    begin
 332       Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X);
 333    end Update_Exception_NT;
 334
 335 end System.Soft_Links;