gcc/ada/5ntaprop.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
   4 --                                                                          --
   5 --     S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S    --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --         Copyright (C) 1992-2002, Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNARL 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. GNARL 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 GNARL; 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 -- GNARL was developed by the GNARL team at Florida State University.       --
  30 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This is a no tasking version of this package
  35
  36 --  This package contains all the GNULL primitives that interface directly
  37 --  with the underlying OS.
  38
  39 pragma Polling (Off);
  40 --  Turn off polling, we do not want ATC polling to take place during
  41 --  tasking operations. It causes infinite loops and other problems.
  42
  43 with System.Tasking;
  44 --  used for Ada_Task_Control_Block
  45 --           Task_ID
  46
  47 with System.Error_Reporting;
  48 --  used for Shutdown
  49
  50 package body System.Task_Primitives.Operations is
  51
  52    use System.Tasking;
  53    use System.Parameters;
  54
  55    pragma Warnings (Off);
  56    --  Turn off warnings since so many unreferenced parameters
  57
  58    -----------------
  59    -- Stack_Guard --
  60    -----------------
  61
  62    procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
  63    begin
  64       null;
  65    end Stack_Guard;
  66
  67    --------------------
  68    -- Get_Thread_Id  --
  69    --------------------
  70
  71    function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
  72    begin
  73       return OSI.Thread_Id (T.Common.LL.Thread);
  74    end Get_Thread_Id;
  75
  76    ----------
  77    -- Self --
  78    ----------
  79
  80    function Self return Task_ID is
  81    begin
  82       return Null_Task;
  83    end Self;
  84
  85    ---------------------
  86    -- Initialize_Lock --
  87    ---------------------
  88
  89    procedure Initialize_Lock
  90      (Prio : System.Any_Priority;
  91       L    : access Lock)
  92    is
  93    begin
  94       null;
  95    end Initialize_Lock;
  96
  97    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
  98    begin
  99       null;
 100    end Initialize_Lock;
 101
 102    -------------------
 103    -- Finalize_Lock --
 104    -------------------
 105
 106    procedure Finalize_Lock (L : access Lock) is
 107    begin
 108       null;
 109    end Finalize_Lock;
 110
 111    procedure Finalize_Lock (L : access RTS_Lock) is
 112    begin
 113       null;
 114    end Finalize_Lock;
 115
 116    ----------------
 117    -- Write_Lock --
 118    ----------------
 119
 120    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 121    begin
 122       Ceiling_Violation := False;
 123    end Write_Lock;
 124
 125    procedure Write_Lock
 126      (L           : access RTS_Lock;
 127       Global_Lock : Boolean := False)
 128    is
 129    begin
 130       null;
 131    end Write_Lock;
 132
 133    procedure Write_Lock (T : Task_ID) is
 134    begin
 135       null;
 136    end Write_Lock;
 137
 138    ---------------
 139    -- Read_Lock --
 140    ---------------
 141
 142    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 143    begin
 144       Ceiling_Violation := False;
 145    end Read_Lock;
 146
 147    ------------
 148    -- Unlock --
 149    ------------
 150
 151    procedure Unlock (L : access Lock) is
 152    begin
 153       null;
 154    end Unlock;
 155
 156    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 157    begin
 158       null;
 159    end Unlock;
 160
 161    procedure Unlock (T : Task_ID) is
 162    begin
 163       null;
 164    end Unlock;
 165
 166    -----------
 167    -- Sleep --
 168    -----------
 169
 170    procedure Sleep (Self_ID : Task_ID; Reason  : System.Tasking.Task_States) is
 171    begin
 172       null;
 173    end Sleep;
 174
 175    -----------------
 176    -- Timed_Sleep --
 177    -----------------
 178
 179    procedure Timed_Sleep
 180      (Self_ID  : Task_ID;
 181       Time     : Duration;
 182       Mode     : ST.Delay_Modes;
 183       Reason   : System.Tasking.Task_States;
 184       Timedout : out Boolean;
 185       Yielded  : out Boolean) is
 186    begin
 187       Timedout := False;
 188       Yielded := False;
 189    end Timed_Sleep;
 190
 191    -----------------
 192    -- Timed_Delay --
 193    -----------------
 194
 195    procedure Timed_Delay
 196      (Self_ID : Task_ID;
 197       Time    : Duration;
 198       Mode    : ST.Delay_Modes) is
 199    begin
 200       null;
 201    end Timed_Delay;
 202
 203    ---------------------
 204    -- Monotonic_Clock --
 205    ---------------------
 206
 207    function Monotonic_Clock return Duration is
 208    begin
 209       return 0.0;
 210    end Monotonic_Clock;
 211
 212    -------------------
 213    -- RT_Resolution --
 214    -------------------
 215
 216    function RT_Resolution return Duration is
 217    begin
 218       return 10#1.0#E-6;
 219    end RT_Resolution;
 220
 221    ------------
 222    -- Wakeup --
 223    ------------
 224
 225    procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
 226    begin
 227       null;
 228    end Wakeup;
 229
 230    ------------------
 231    -- Set_Priority --
 232    ------------------
 233
 234    procedure Set_Priority
 235      (T                   : Task_ID;
 236       Prio                : System.Any_Priority;
 237       Loss_Of_Inheritance : Boolean := False) is
 238    begin
 239       null;
 240    end Set_Priority;
 241
 242    ------------------
 243    -- Get_Priority --
 244    ------------------
 245
 246    function Get_Priority (T : Task_ID) return System.Any_Priority is
 247    begin
 248       return 0;
 249    end Get_Priority;
 250
 251    ----------------
 252    -- Enter_Task --
 253    ----------------
 254
 255    procedure Enter_Task (Self_ID : Task_ID) is
 256    begin
 257       null;
 258    end Enter_Task;
 259
 260    --------------
 261    -- New_ATCB --
 262    --------------
 263
 264    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
 265    begin
 266       return new Ada_Task_Control_Block (Entry_Num);
 267    end New_ATCB;
 268
 269    -------------------
 270    -- Is_Valid_Task --
 271    -------------------
 272
 273    function Is_Valid_Task return Boolean is
 274    begin
 275       return False;
 276    end Is_Valid_Task;
 277
 278    -----------------------------
 279    -- Register_Foreign_Thread --
 280    -----------------------------
 281
 282    function Register_Foreign_Thread return Task_ID is
 283    begin
 284       return null;
 285    end Register_Foreign_Thread;
 286
 287    ----------------------
 288    --  Initialize_TCB  --
 289    ----------------------
 290
 291    procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
 292    begin
 293       Succeeded := False;
 294    end Initialize_TCB;
 295
 296    -----------------
 297    -- Create_Task --
 298    -----------------
 299
 300    procedure Create_Task
 301      (T          : Task_ID;
 302       Wrapper    : System.Address;
 303       Stack_Size : System.Parameters.Size_Type;
 304       Priority   : System.Any_Priority;
 305       Succeeded  : out Boolean) is
 306    begin
 307       Succeeded := False;
 308    end Create_Task;
 309
 310    ------------------
 311    -- Finalize_TCB --
 312    ------------------
 313
 314    procedure Finalize_TCB (T : Task_ID) is
 315    begin
 316       null;
 317    end Finalize_TCB;
 318
 319    ---------------
 320    -- Exit_Task --
 321    ---------------
 322
 323    procedure Exit_Task is
 324    begin
 325       null;
 326    end Exit_Task;
 327
 328    ----------------
 329    -- Abort_Task --
 330    ----------------
 331
 332    procedure Abort_Task (T : Task_ID) is
 333    begin
 334       null;
 335    end Abort_Task;
 336
 337    -----------
 338    -- Yield --
 339    -----------
 340
 341    procedure Yield (Do_Yield : Boolean := True) is
 342    begin
 343       null;
 344    end Yield;
 345
 346    ----------------
 347    -- Check_Exit --
 348    ----------------
 349
 350    --  Dummy versions.  The only currently working versions is for solaris
 351    --  (native).
 352
 353    function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
 354    begin
 355       return True;
 356    end Check_Exit;
 357
 358    --------------------
 359    -- Check_No_Locks --
 360    --------------------
 361
 362    function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
 363    begin
 364       return True;
 365    end Check_No_Locks;
 366
 367    ----------------------
 368    -- Environment_Task --
 369    ----------------------
 370
 371    function Environment_Task return Task_ID is
 372    begin
 373       return null;
 374    end Environment_Task;
 375
 376    --------------
 377    -- Lock_RTS --
 378    --------------
 379
 380    procedure Lock_RTS is
 381    begin
 382       null;
 383    end Lock_RTS;
 384
 385    ----------------
 386    -- Unlock_RTS --
 387    ----------------
 388
 389    procedure Unlock_RTS is
 390    begin
 391       null;
 392    end Unlock_RTS;
 393
 394    ------------------
 395    -- Suspend_Task --
 396    ------------------
 397
 398    function Suspend_Task
 399      (T           : ST.Task_ID;
 400       Thread_Self : OSI.Thread_Id)
 401       return        Boolean
 402    is
 403    begin
 404       return False;
 405    end Suspend_Task;
 406
 407    -----------------
 408    -- Resume_Task --
 409    -----------------
 410
 411    function Resume_Task
 412      (T           : ST.Task_ID;
 413       Thread_Self : OSI.Thread_Id)
 414       return        Boolean
 415    is
 416    begin
 417       return False;
 418    end Resume_Task;
 419
 420    ----------------
 421    -- Initialize --
 422    ----------------
 423
 424    procedure Initialize (Environment_Task : Task_ID) is
 425    begin
 426       null;
 427    end Initialize;
 428
 429    No_Tasking : Boolean;
 430
 431 begin
 432    --  Can't raise an exception because target independent packages try to
 433    --  do an Abort_Defer, which gets a memory fault.
 434
 435    No_Tasking :=
 436      System.Error_Reporting.Shutdown
 437        ("Tasking not implemented on this configuration");
 438 end System.Task_Primitives.Operations;