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 --                            $Revision$
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 pragma Polling (Off);
  37 --  We must turn polling off for this unit, because otherwise we get
  38 --  an infinite loop from the code within the Poll routine itself.
  39
  40 with System.Machine_State_Operations; use System.Machine_State_Operations;
  41 --  Used for Create_TSD, Destroy_TSD
  42
  43 with System.Parameters;
  44 --  Used for Sec_Stack_Ratio
  45
  46 with System.Secondary_Stack;
  47
  48 package body System.Soft_Links is
  49
  50    package SST renames System.Secondary_Stack;
  51
  52    --  Allocate an exception stack for the main program to use.
  53    --  We make sure that the stack has maximum alignment. Some systems require
  54    --  this (e.g. Sun), and in any case it is a good idea for efficiency.
  55
  56    NT_Exc_Stack : array (0 .. 8192) of aliased Character;
  57    for NT_Exc_Stack'Alignment use Standard'Maximum_Alignment;
  58
  59    NT_TSD : 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    -- Check_Abort_Status_NT --
  90    ---------------------------
  91
  92    function Check_Abort_Status_NT return Integer is
  93    begin
  94       return Boolean'Pos (False);
  95    end Check_Abort_Status_NT;
  96
  97    ------------------------
  98    -- Complete_Master_NT --
  99    ------------------------
 100
 101    procedure Complete_Master_NT is
 102    begin
 103       null;
 104    end Complete_Master_NT;
 105
 106    ----------------
 107    -- Create_TSD --
 108    ----------------
 109
 110    procedure Create_TSD (New_TSD : in out TSD) is
 111       use type Parameters.Size_Type;
 112
 113       SS_Ratio_Dynamic : constant Boolean :=
 114                            Parameters.Sec_Stack_Ratio = Parameters.Dynamic;
 115
 116    begin
 117       if SS_Ratio_Dynamic then
 118          SST.SS_Init
 119            (New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size);
 120       end if;
 121
 122       New_TSD.Machine_State_Addr :=
 123         System.Address
 124           (System.Machine_State_Operations.Allocate_Machine_State);
 125    end Create_TSD;
 126
 127    -----------------------
 128    -- Current_Master_NT --
 129    -----------------------
 130
 131    function Current_Master_NT return Integer is
 132    begin
 133       return 0;
 134    end Current_Master_NT;
 135
 136    -----------------
 137    -- Destroy_TSD --
 138    -----------------
 139
 140    procedure Destroy_TSD (Old_TSD : in out TSD) is
 141    begin
 142       SST.SS_Free (Old_TSD.Sec_Stack_Addr);
 143       System.Machine_State_Operations.Free_Machine_State
 144         (Machine_State (Old_TSD.Machine_State_Addr));
 145    end Destroy_TSD;
 146
 147    ---------------------
 148    -- Enter_Master_NT --
 149    ---------------------
 150
 151    procedure Enter_Master_NT is
 152    begin
 153       null;
 154    end Enter_Master_NT;
 155
 156    --------------------------
 157    -- Get_Current_Excep_NT --
 158    --------------------------
 159
 160    function Get_Current_Excep_NT return EOA is
 161    begin
 162       return NT_TSD.Current_Excep'Access;
 163    end Get_Current_Excep_NT;
 164
 165    ---------------------------
 166    -- Get_Exc_Stack_Addr_NT --
 167    ---------------------------
 168
 169    function Get_Exc_Stack_Addr_NT return Address is
 170    begin
 171       return NT_TSD.Exc_Stack_Addr;
 172    end Get_Exc_Stack_Addr_NT;
 173
 174    -----------------------------
 175    -- Get_Exc_Stack_Addr_Soft --
 176    -----------------------------
 177
 178    function Get_Exc_Stack_Addr_Soft return  Address is
 179    begin
 180       return Get_Exc_Stack_Addr.all;
 181    end Get_Exc_Stack_Addr_Soft;
 182
 183    ------------------------
 184    -- Get_GNAT_Exception --
 185    ------------------------
 186
 187    function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is
 188    begin
 189       return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all);
 190    end Get_GNAT_Exception;
 191
 192    ---------------------------
 193    -- Get_Jmpbuf_Address_NT --
 194    ---------------------------
 195
 196    function Get_Jmpbuf_Address_NT return  Address is
 197    begin
 198       return NT_TSD.Jmpbuf_Address;
 199    end Get_Jmpbuf_Address_NT;
 200
 201    -----------------------------
 202    -- Get_Jmpbuf_Address_Soft --
 203    -----------------------------
 204
 205    function Get_Jmpbuf_Address_Soft return  Address is
 206    begin
 207       return Get_Jmpbuf_Address.all;
 208    end Get_Jmpbuf_Address_Soft;
 209
 210    -------------------------------
 211    -- Get_Machine_State_Addr_NT --
 212    -------------------------------
 213
 214    function Get_Machine_State_Addr_NT return  Address is
 215    begin
 216       return NT_TSD.Machine_State_Addr;
 217    end Get_Machine_State_Addr_NT;
 218
 219    ---------------------------------
 220    -- Get_Machine_State_Addr_Soft --
 221    ---------------------------------
 222
 223    function Get_Machine_State_Addr_Soft return  Address is
 224    begin
 225       return Get_Machine_State_Addr.all;
 226    end Get_Machine_State_Addr_Soft;
 227
 228    ---------------------------
 229    -- Get_Sec_Stack_Addr_NT --
 230    ---------------------------
 231
 232    function Get_Sec_Stack_Addr_NT return  Address is
 233    begin
 234       return NT_TSD.Sec_Stack_Addr;
 235    end Get_Sec_Stack_Addr_NT;
 236
 237    -----------------------------
 238    -- Get_Sec_Stack_Addr_Soft --
 239    -----------------------------
 240
 241    function Get_Sec_Stack_Addr_Soft return  Address is
 242    begin
 243       return Get_Sec_Stack_Addr.all;
 244    end Get_Sec_Stack_Addr_Soft;
 245
 246    -----------------------
 247    -- Get_Stack_Info_NT --
 248    -----------------------
 249
 250    function Get_Stack_Info_NT return Stack_Checking.Stack_Access is
 251    begin
 252       return NT_TSD.Pri_Stack_Info'Access;
 253    end Get_Stack_Info_NT;
 254
 255    -------------------
 256    -- Null_Adafinal --
 257    -------------------
 258
 259    procedure Null_Adafinal is
 260    begin
 261       null;
 262    end Null_Adafinal;
 263
 264    ---------------------------
 265    -- Set_Exc_Stack_Addr_NT --
 266    ---------------------------
 267
 268    procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address) is
 269       pragma Warnings (Off, Self_ID);
 270
 271    begin
 272       NT_TSD.Exc_Stack_Addr := Addr;
 273    end Set_Exc_Stack_Addr_NT;
 274
 275    -----------------------------
 276    -- Set_Exc_Stack_Addr_Soft --
 277    -----------------------------
 278
 279    procedure Set_Exc_Stack_Addr_Soft (Self_ID : Address; Addr : Address) is
 280    begin
 281       Set_Exc_Stack_Addr (Self_ID, Addr);
 282    end Set_Exc_Stack_Addr_Soft;
 283
 284    ---------------------------
 285    -- Set_Jmpbuf_Address_NT --
 286    ---------------------------
 287
 288    procedure Set_Jmpbuf_Address_NT (Addr : Address) is
 289    begin
 290       NT_TSD.Jmpbuf_Address := Addr;
 291    end Set_Jmpbuf_Address_NT;
 292
 293    procedure Set_Jmpbuf_Address_Soft (Addr : Address) is
 294    begin
 295       Set_Jmpbuf_Address (Addr);
 296    end Set_Jmpbuf_Address_Soft;
 297
 298    -------------------------------
 299    -- Set_Machine_State_Addr_NT --
 300    -------------------------------
 301
 302    procedure Set_Machine_State_Addr_NT (Addr : Address) is
 303    begin
 304       NT_TSD.Machine_State_Addr := Addr;
 305    end Set_Machine_State_Addr_NT;
 306
 307    ---------------------------------
 308    -- Set_Machine_State_Addr_Soft --
 309    ---------------------------------
 310
 311    procedure Set_Machine_State_Addr_Soft (Addr : Address) is
 312    begin
 313       Set_Machine_State_Addr (Addr);
 314    end Set_Machine_State_Addr_Soft;
 315
 316    ---------------------------
 317    -- Set_Sec_Stack_Addr_NT --
 318    ---------------------------
 319
 320    procedure Set_Sec_Stack_Addr_NT (Addr : Address) is
 321    begin
 322       NT_TSD.Sec_Stack_Addr := Addr;
 323    end Set_Sec_Stack_Addr_NT;
 324
 325    -----------------------------
 326    -- Set_Sec_Stack_Addr_Soft --
 327    -----------------------------
 328
 329    procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is
 330    begin
 331       Set_Sec_Stack_Addr (Addr);
 332    end Set_Sec_Stack_Addr_Soft;
 333
 334    ------------------
 335    -- Task_Lock_NT --
 336    ------------------
 337
 338    procedure Task_Lock_NT is
 339    begin
 340       null;
 341    end Task_Lock_NT;
 342
 343    --------------------
 344    -- Task_Unlock_NT --
 345    --------------------
 346
 347    procedure Task_Unlock_NT is
 348    begin
 349       null;
 350    end Task_Unlock_NT;
 351
 352    -------------------------
 353    -- Update_Exception_NT --
 354    -------------------------
 355
 356    procedure Update_Exception_NT (X : EO := Current_Target_Exception) is
 357    begin
 358       Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X);
 359    end Update_Exception_NT;
 360
 361    ------------------
 362    -- Task_Name_NT --
 363    -------------------
 364
 365    function Task_Name_NT return String is
 366    begin
 367       return "main_task";
 368    end Task_Name_NT;
 369
 370    -------------------------
 371    -- Package Elaboration --
 372    -------------------------
 373
 374 begin
 375    NT_TSD.Exc_Stack_Addr := NT_Exc_Stack (8192)'Address;
 376    Ada.Exceptions.Save_Occurrence
 377      (NT_TSD.Current_Excep, Ada.Exceptions.Null_Occurrence);
 378
 379 end System.Soft_Links;