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. It is --
  30 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com).     --
  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    --  Initialize_TCB  --
 271    ----------------------
 272
 273    procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
 274    begin
 275       Succeeded := False;
 276    end Initialize_TCB;
 277
 278    -----------------
 279    -- Create_Task --
 280    -----------------
 281
 282    procedure Create_Task
 283      (T          : Task_ID;
 284       Wrapper    : System.Address;
 285       Stack_Size : System.Parameters.Size_Type;
 286       Priority   : System.Any_Priority;
 287       Succeeded  : out Boolean) is
 288    begin
 289       Succeeded := False;
 290    end Create_Task;
 291
 292    ------------------
 293    -- Finalize_TCB --
 294    ------------------
 295
 296    procedure Finalize_TCB (T : Task_ID) is
 297    begin
 298       null;
 299    end Finalize_TCB;
 300
 301    ---------------
 302    -- Exit_Task --
 303    ---------------
 304
 305    procedure Exit_Task is
 306    begin
 307       null;
 308    end Exit_Task;
 309
 310    ----------------
 311    -- Abort_Task --
 312    ----------------
 313
 314    procedure Abort_Task (T : Task_ID) is
 315    begin
 316       null;
 317    end Abort_Task;
 318
 319    -----------
 320    -- Yield --
 321    -----------
 322
 323    procedure Yield (Do_Yield : Boolean := True) is
 324    begin
 325       null;
 326    end Yield;
 327
 328    ----------------
 329    -- Check_Exit --
 330    ----------------
 331
 332    --  Dummy versions.  The only currently working versions is for solaris
 333    --  (native).
 334
 335    function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
 336    begin
 337       return True;
 338    end Check_Exit;
 339
 340    --------------------
 341    -- Check_No_Locks --
 342    --------------------
 343
 344    function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
 345    begin
 346       return True;
 347    end Check_No_Locks;
 348
 349    ----------------------
 350    -- Environment_Task --
 351    ----------------------
 352
 353    function Environment_Task return Task_ID is
 354    begin
 355       return null;
 356    end Environment_Task;
 357
 358    --------------
 359    -- Lock_RTS --
 360    --------------
 361
 362    procedure Lock_RTS is
 363    begin
 364       null;
 365    end Lock_RTS;
 366
 367    ----------------
 368    -- Unlock_RTS --
 369    ----------------
 370
 371    procedure Unlock_RTS is
 372    begin
 373       null;
 374    end Unlock_RTS;
 375
 376    ------------------
 377    -- Suspend_Task --
 378    ------------------
 379
 380    function Suspend_Task
 381      (T           : ST.Task_ID;
 382       Thread_Self : OSI.Thread_Id)
 383       return        Boolean
 384    is
 385    begin
 386       return False;
 387    end Suspend_Task;
 388
 389    -----------------
 390    -- Resume_Task --
 391    -----------------
 392
 393    function Resume_Task
 394      (T           : ST.Task_ID;
 395       Thread_Self : OSI.Thread_Id)
 396       return        Boolean
 397    is
 398    begin
 399       return False;
 400    end Resume_Task;
 401
 402    ----------------
 403    -- Initialize --
 404    ----------------
 405
 406    procedure Initialize (Environment_Task : Task_ID) is
 407    begin
 408       null;
 409    end Initialize;
 410
 411    No_Tasking : Boolean;
 412
 413 begin
 414    --  Can't raise an exception because target independent packages try to
 415    --  do an Abort_Defer, which gets a memory fault.
 416
 417    No_Tasking :=
 418      System.Error_Reporting.Shutdown
 419        ("Tasking not implemented on this configuration");
 420 end System.Task_Primitives.Operations;