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