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-2001 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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.Machine_State_Operations; use System.Machine_State_Operations;
  39 --  Used for Create_TSD, Destroy_TSD
  40
  41 with System.Parameters;
  42 --  Used for Sec_Stack_Ratio
  43
  44 with System.Secondary_Stack;
  45
  46 package body System.Soft_Links is
  47
  48    package SST renames System.Secondary_Stack;
  49
  50    --  Allocate an exception stack for the main program to use.
  51    --  We make sure that the stack has maximum alignment. Some systems require
  52    --  this (e.g. Sun), and in any case it is a good idea for efficiency.
  53
  54    NT_Exc_Stack : array (0 .. 8192) of aliased Character;
  55    for NT_Exc_Stack'Alignment use Standard'Maximum_Alignment;
  56
  57    NT_TSD : 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
 120       New_TSD.Machine_State_Addr :=
 121         System.Address
 122           (System.Machine_State_Operations.Allocate_Machine_State);
 123    end Create_TSD;
 124
 125    -----------------------
 126    -- Current_Master_NT --
 127    -----------------------
 128
 129    function Current_Master_NT return Integer is
 130    begin
 131       return 0;
 132    end Current_Master_NT;
 133
 134    -----------------
 135    -- Destroy_TSD --
 136    -----------------
 137
 138    procedure Destroy_TSD (Old_TSD : in out TSD) is
 139    begin
 140       SST.SS_Free (Old_TSD.Sec_Stack_Addr);
 141       System.Machine_State_Operations.Free_Machine_State
 142         (Machine_State (Old_TSD.Machine_State_Addr));
 143    end Destroy_TSD;
 144
 145    ---------------------
 146    -- Enter_Master_NT --
 147    ---------------------
 148
 149    procedure Enter_Master_NT is
 150    begin
 151       null;
 152    end Enter_Master_NT;
 153
 154    --------------------------
 155    -- Get_Current_Excep_NT --
 156    --------------------------
 157
 158    function Get_Current_Excep_NT return EOA is
 159    begin
 160       return NT_TSD.Current_Excep'Access;
 161    end Get_Current_Excep_NT;
 162
 163    ---------------------------
 164    -- Get_Exc_Stack_Addr_NT --
 165    ---------------------------
 166
 167    function Get_Exc_Stack_Addr_NT return Address is
 168    begin
 169       return NT_TSD.Exc_Stack_Addr;
 170    end Get_Exc_Stack_Addr_NT;
 171
 172    -----------------------------
 173    -- Get_Exc_Stack_Addr_Soft --
 174    -----------------------------
 175
 176    function Get_Exc_Stack_Addr_Soft return  Address is
 177    begin
 178       return Get_Exc_Stack_Addr.all;
 179    end Get_Exc_Stack_Addr_Soft;
 180
 181    ------------------------
 182    -- Get_GNAT_Exception --
 183    ------------------------
 184
 185    function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is
 186    begin
 187       return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all);
 188    end Get_GNAT_Exception;
 189
 190    ---------------------------
 191    -- Get_Jmpbuf_Address_NT --
 192    ---------------------------
 193
 194    function Get_Jmpbuf_Address_NT return  Address is
 195    begin
 196       return NT_TSD.Jmpbuf_Address;
 197    end Get_Jmpbuf_Address_NT;
 198
 199    -----------------------------
 200    -- Get_Jmpbuf_Address_Soft --
 201    -----------------------------
 202
 203    function Get_Jmpbuf_Address_Soft return  Address is
 204    begin
 205       return Get_Jmpbuf_Address.all;
 206    end Get_Jmpbuf_Address_Soft;
 207
 208    -------------------------------
 209    -- Get_Machine_State_Addr_NT --
 210    -------------------------------
 211
 212    function Get_Machine_State_Addr_NT return  Address is
 213    begin
 214       return NT_TSD.Machine_State_Addr;
 215    end Get_Machine_State_Addr_NT;
 216
 217    ---------------------------------
 218    -- Get_Machine_State_Addr_Soft --
 219    ---------------------------------
 220
 221    function Get_Machine_State_Addr_Soft return  Address is
 222    begin
 223       return Get_Machine_State_Addr.all;
 224    end Get_Machine_State_Addr_Soft;
 225
 226    ---------------------------
 227    -- Get_Sec_Stack_Addr_NT --
 228    ---------------------------
 229
 230    function Get_Sec_Stack_Addr_NT return  Address is
 231    begin
 232       return NT_TSD.Sec_Stack_Addr;
 233    end Get_Sec_Stack_Addr_NT;
 234
 235    -----------------------------
 236    -- Get_Sec_Stack_Addr_Soft --
 237    -----------------------------
 238
 239    function Get_Sec_Stack_Addr_Soft return  Address is
 240    begin
 241       return Get_Sec_Stack_Addr.all;
 242    end Get_Sec_Stack_Addr_Soft;
 243
 244    -----------------------
 245    -- Get_Stack_Info_NT --
 246    -----------------------
 247
 248    function Get_Stack_Info_NT return Stack_Checking.Stack_Access is
 249    begin
 250       return NT_TSD.Pri_Stack_Info'Access;
 251    end Get_Stack_Info_NT;
 252
 253    -------------------
 254    -- Null_Adafinal --
 255    -------------------
 256
 257    procedure Null_Adafinal is
 258    begin
 259       null;
 260    end Null_Adafinal;
 261
 262    ---------------------------
 263    -- Set_Exc_Stack_Addr_NT --
 264    ---------------------------
 265
 266    procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address) is
 267       pragma Warnings (Off, Self_ID);
 268
 269    begin
 270       NT_TSD.Exc_Stack_Addr := Addr;
 271    end Set_Exc_Stack_Addr_NT;
 272
 273    -----------------------------
 274    -- Set_Exc_Stack_Addr_Soft --
 275    -----------------------------
 276
 277    procedure Set_Exc_Stack_Addr_Soft (Self_ID : Address; Addr : Address) is
 278    begin
 279       Set_Exc_Stack_Addr (Self_ID, Addr);
 280    end Set_Exc_Stack_Addr_Soft;
 281
 282    ---------------------------
 283    -- Set_Jmpbuf_Address_NT --
 284    ---------------------------
 285
 286    procedure Set_Jmpbuf_Address_NT (Addr : Address) is
 287    begin
 288       NT_TSD.Jmpbuf_Address := Addr;
 289    end Set_Jmpbuf_Address_NT;
 290
 291    procedure Set_Jmpbuf_Address_Soft (Addr : Address) is
 292    begin
 293       Set_Jmpbuf_Address (Addr);
 294    end Set_Jmpbuf_Address_Soft;
 295
 296    -------------------------------
 297    -- Set_Machine_State_Addr_NT --
 298    -------------------------------
 299
 300    procedure Set_Machine_State_Addr_NT (Addr : Address) is
 301    begin
 302       NT_TSD.Machine_State_Addr := Addr;
 303    end Set_Machine_State_Addr_NT;
 304
 305    ---------------------------------
 306    -- Set_Machine_State_Addr_Soft --
 307    ---------------------------------
 308
 309    procedure Set_Machine_State_Addr_Soft (Addr : Address) is
 310    begin
 311       Set_Machine_State_Addr (Addr);
 312    end Set_Machine_State_Addr_Soft;
 313
 314    ---------------------------
 315    -- Set_Sec_Stack_Addr_NT --
 316    ---------------------------
 317
 318    procedure Set_Sec_Stack_Addr_NT (Addr : Address) is
 319    begin
 320       NT_TSD.Sec_Stack_Addr := Addr;
 321    end Set_Sec_Stack_Addr_NT;
 322
 323    -----------------------------
 324    -- Set_Sec_Stack_Addr_Soft --
 325    -----------------------------
 326
 327    procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is
 328    begin
 329       Set_Sec_Stack_Addr (Addr);
 330    end Set_Sec_Stack_Addr_Soft;
 331
 332    ------------------
 333    -- Task_Lock_NT --
 334    ------------------
 335
 336    procedure Task_Lock_NT is
 337    begin
 338       null;
 339    end Task_Lock_NT;
 340
 341    --------------------
 342    -- Task_Unlock_NT --
 343    --------------------
 344
 345    procedure Task_Unlock_NT is
 346    begin
 347       null;
 348    end Task_Unlock_NT;
 349
 350    -------------------------
 351    -- Update_Exception_NT --
 352    -------------------------
 353
 354    procedure Update_Exception_NT (X : EO := Current_Target_Exception) is
 355    begin
 356       Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X);
 357    end Update_Exception_NT;
 358
 359    ------------------
 360    -- Task_Name_NT --
 361    -------------------
 362
 363    function Task_Name_NT return String is
 364    begin
 365       return "main_task";
 366    end Task_Name_NT;
 367
 368    -------------------------
 369    -- Package Elaboration --
 370    -------------------------
 371
 372 begin
 373    NT_TSD.Exc_Stack_Addr := NT_Exc_Stack (8192)'Address;
 374    Ada.Exceptions.Save_Occurrence
 375      (NT_TSD.Current_Excep, Ada.Exceptions.Null_Occurrence);
 376
 377 end System.Soft_Links;