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-2007, 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 Warnings (Off);
  35 pragma Compiler_Unit;
  36 pragma Warnings (On);
  37
  38 pragma Polling (Off);
  39 --  We must turn polling off for this unit, because otherwise we get
  40 --  an infinite loop from the code within the Poll routine itself.
  41
  42 with System.Parameters;
  43 --  Used for Sec_Stack_Ratio
  44
  45 pragma Warnings (Off);
  46 --  Disable warnings since System.Secondary_Stack is currently not
  47 --  Preelaborate
  48 with System.Secondary_Stack;
  49 pragma Warnings (On);
  50
  51 package body System.Soft_Links is
  52
  53    package SST renames System.Secondary_Stack;
  54
  55    NT_Exc_Stack : array (0 .. 8192) of aliased Character;
  56    for NT_Exc_Stack'Alignment use Standard'Maximum_Alignment;
  57    --  Allocate an exception stack for the main program to use.
  58    --  This is currently only used under VMS.
  59
  60    NT_TSD : TSD;
  61    --  Note: we rely on the default initialization of NT_TSD
  62
  63    --------------------
  64    -- Abort_Defer_NT --
  65    --------------------
  66
  67    procedure Abort_Defer_NT is
  68    begin
  69       null;
  70    end Abort_Defer_NT;
  71
  72    ----------------------
  73    -- Abort_Handler_NT --
  74    ----------------------
  75
  76    procedure Abort_Handler_NT is
  77    begin
  78       null;
  79    end Abort_Handler_NT;
  80
  81    ----------------------
  82    -- Abort_Undefer_NT --
  83    ----------------------
  84
  85    procedure Abort_Undefer_NT is
  86    begin
  87       null;
  88    end Abort_Undefer_NT;
  89
  90    -----------------
  91    -- Adafinal_NT --
  92    -----------------
  93
  94    procedure Adafinal_NT is
  95    begin
  96       --  Handle normal task termination by the environment task, but only
  97       --  for the normal task termination. In the case of Abnormal and
  98       --  Unhandled_Exception they must have been handled before, and the
  99       --  task termination soft link must have been changed so the task
 100       --  termination routine is not executed twice.
 101
 102       Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
 103
 104       --  Finalize the global list for controlled objects if needed
 105
 106       Finalize_Global_List.all;
 107    end Adafinal_NT;
 108
 109    ---------------------------
 110    -- Check_Abort_Status_NT --
 111    ---------------------------
 112
 113    function Check_Abort_Status_NT return Integer is
 114    begin
 115       return Boolean'Pos (False);
 116    end Check_Abort_Status_NT;
 117
 118    ------------------------
 119    -- Complete_Master_NT --
 120    ------------------------
 121
 122    procedure Complete_Master_NT is
 123    begin
 124       null;
 125    end Complete_Master_NT;
 126
 127    ----------------
 128    -- Create_TSD --
 129    ----------------
 130
 131    procedure Create_TSD (New_TSD : in out TSD) is
 132       use type Parameters.Size_Type;
 133
 134       SS_Ratio_Dynamic : constant Boolean :=
 135                            Parameters.Sec_Stack_Ratio = Parameters.Dynamic;
 136
 137    begin
 138       if SS_Ratio_Dynamic then
 139          SST.SS_Init
 140            (New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size);
 141       end if;
 142    end Create_TSD;
 143
 144    -----------------------
 145    -- Current_Master_NT --
 146    -----------------------
 147
 148    function Current_Master_NT return Integer is
 149    begin
 150       return 0;
 151    end Current_Master_NT;
 152
 153    -----------------
 154    -- Destroy_TSD --
 155    -----------------
 156
 157    procedure Destroy_TSD (Old_TSD : in out TSD) is
 158    begin
 159       SST.SS_Free (Old_TSD.Sec_Stack_Addr);
 160    end Destroy_TSD;
 161
 162    ---------------------
 163    -- Enter_Master_NT --
 164    ---------------------
 165
 166    procedure Enter_Master_NT is
 167    begin
 168       null;
 169    end Enter_Master_NT;
 170
 171    --------------------------
 172    -- Get_Current_Excep_NT --
 173    --------------------------
 174
 175    function Get_Current_Excep_NT return EOA is
 176    begin
 177       return NT_TSD.Current_Excep'Access;
 178    end Get_Current_Excep_NT;
 179
 180    ---------------------------
 181    -- Get_Exc_Stack_Addr_NT --
 182    ---------------------------
 183
 184    function Get_Exc_Stack_Addr_NT return Address is
 185    begin
 186       return NT_Exc_Stack (NT_Exc_Stack'Last)'Address;
 187    end Get_Exc_Stack_Addr_NT;
 188
 189    -----------------------------
 190    -- Get_Exc_Stack_Addr_Soft --
 191    -----------------------------
 192
 193    function Get_Exc_Stack_Addr_Soft return Address is
 194    begin
 195       return Get_Exc_Stack_Addr.all;
 196    end Get_Exc_Stack_Addr_Soft;
 197
 198    ------------------------
 199    -- Get_GNAT_Exception --
 200    ------------------------
 201
 202    function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is
 203    begin
 204       return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all);
 205    end Get_GNAT_Exception;
 206
 207    ---------------------------
 208    -- Get_Jmpbuf_Address_NT --
 209    ---------------------------
 210
 211    function Get_Jmpbuf_Address_NT return  Address is
 212    begin
 213       return NT_TSD.Jmpbuf_Address;
 214    end Get_Jmpbuf_Address_NT;
 215
 216    -----------------------------
 217    -- Get_Jmpbuf_Address_Soft --
 218    -----------------------------
 219
 220    function Get_Jmpbuf_Address_Soft return  Address is
 221    begin
 222       return Get_Jmpbuf_Address.all;
 223    end Get_Jmpbuf_Address_Soft;
 224
 225    ---------------------------
 226    -- Get_Sec_Stack_Addr_NT --
 227    ---------------------------
 228
 229    function Get_Sec_Stack_Addr_NT return  Address is
 230    begin
 231       return NT_TSD.Sec_Stack_Addr;
 232    end Get_Sec_Stack_Addr_NT;
 233
 234    -----------------------------
 235    -- Get_Sec_Stack_Addr_Soft --
 236    -----------------------------
 237
 238    function Get_Sec_Stack_Addr_Soft return  Address is
 239    begin
 240       return Get_Sec_Stack_Addr.all;
 241    end Get_Sec_Stack_Addr_Soft;
 242
 243    -----------------------
 244    -- Get_Stack_Info_NT --
 245    -----------------------
 246
 247    function Get_Stack_Info_NT return Stack_Checking.Stack_Access is
 248    begin
 249       return NT_TSD.Pri_Stack_Info'Access;
 250    end Get_Stack_Info_NT;
 251
 252    -------------------------------
 253    -- Null_Finalize_Global_List --
 254    -------------------------------
 255
 256    procedure Null_Finalize_Global_List is
 257    begin
 258       null;
 259    end Null_Finalize_Global_List;
 260
 261    ---------------------------
 262    -- Set_Jmpbuf_Address_NT --
 263    ---------------------------
 264
 265    procedure Set_Jmpbuf_Address_NT (Addr : Address) is
 266    begin
 267       NT_TSD.Jmpbuf_Address := Addr;
 268    end Set_Jmpbuf_Address_NT;
 269
 270    procedure Set_Jmpbuf_Address_Soft (Addr : Address) is
 271    begin
 272       Set_Jmpbuf_Address (Addr);
 273    end Set_Jmpbuf_Address_Soft;
 274
 275    ---------------------------
 276    -- Set_Sec_Stack_Addr_NT --
 277    ---------------------------
 278
 279    procedure Set_Sec_Stack_Addr_NT (Addr : Address) is
 280    begin
 281       NT_TSD.Sec_Stack_Addr := Addr;
 282    end Set_Sec_Stack_Addr_NT;
 283
 284    -----------------------------
 285    -- Set_Sec_Stack_Addr_Soft --
 286    -----------------------------
 287
 288    procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is
 289    begin
 290       Set_Sec_Stack_Addr (Addr);
 291    end Set_Sec_Stack_Addr_Soft;
 292
 293    ------------------
 294    -- Task_Lock_NT --
 295    ------------------
 296
 297    procedure Task_Lock_NT is
 298    begin
 299       null;
 300    end Task_Lock_NT;
 301
 302    ------------------
 303    -- Task_Name_NT --
 304    -------------------
 305
 306    function Task_Name_NT return String is
 307    begin
 308       return "main_task";
 309    end Task_Name_NT;
 310
 311    -------------------------
 312    -- Task_Termination_NT --
 313    -------------------------
 314
 315    procedure Task_Termination_NT (Excep : EO) is
 316       pragma Warnings (Off, Excep);
 317    begin
 318       null;
 319    end Task_Termination_NT;
 320
 321    --------------------
 322    -- Task_Unlock_NT --
 323    --------------------
 324
 325    procedure Task_Unlock_NT is
 326    begin
 327       null;
 328    end Task_Unlock_NT;
 329
 330    -------------------------
 331    -- Update_Exception_NT --
 332    -------------------------
 333
 334    procedure Update_Exception_NT (X : EO := Current_Target_Exception) is
 335    begin
 336       Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X);
 337    end Update_Exception_NT;
 338
 339 end System.Soft_Links;