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