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