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