gcc/ada/s-taprop-dummy.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                 GNAT 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-2005, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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    No_Tasking : Boolean;
  59    --  Comment required here ???
  60
  61    ----------------
  62    -- Abort_Task --
  63    ----------------
  64
  65    procedure Abort_Task (T : Task_Id) is
  66    begin
  67       null;
  68    end Abort_Task;
  69
  70    ----------------
  71    -- Check_Exit --
  72    ----------------
  73
  74    --  Dummy version
  75
  76    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
  77    begin
  78       return True;
  79    end Check_Exit;
  80
  81    --------------------
  82    -- Check_No_Locks --
  83    --------------------
  84
  85    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
  86    begin
  87       return True;
  88    end Check_No_Locks;
  89
  90    -------------------
  91    -- Current_State --
  92    -------------------
  93
  94    function Current_State (S : Suspension_Object) return Boolean is
  95    begin
  96       return False;
  97    end Current_State;
  98
  99    ----------------------
 100    -- Environment_Task --
 101    ----------------------
 102
 103    function Environment_Task return Task_Id is
 104    begin
 105       return null;
 106    end Environment_Task;
 107
 108    -----------------
 109    -- Create_Task --
 110    -----------------
 111
 112    procedure Create_Task
 113      (T          : Task_Id;
 114       Wrapper    : System.Address;
 115       Stack_Size : System.Parameters.Size_Type;
 116       Priority   : System.Any_Priority;
 117       Succeeded  : out Boolean)
 118    is
 119    begin
 120       Succeeded := False;
 121    end Create_Task;
 122
 123    ----------------
 124    -- Enter_Task --
 125    ----------------
 126
 127    procedure Enter_Task (Self_ID : Task_Id) is
 128    begin
 129       null;
 130    end Enter_Task;
 131
 132    ---------------
 133    -- Exit_Task --
 134    ---------------
 135
 136    procedure Exit_Task is
 137    begin
 138       null;
 139    end Exit_Task;
 140
 141    --------------
 142    -- Finalize --
 143    --------------
 144
 145    procedure Finalize (S : in out Suspension_Object) is
 146    begin
 147       null;
 148    end Finalize;
 149
 150    -------------------
 151    -- Finalize_Lock --
 152    -------------------
 153
 154    procedure Finalize_Lock (L : access Lock) is
 155    begin
 156       null;
 157    end Finalize_Lock;
 158
 159    procedure Finalize_Lock (L : access RTS_Lock) is
 160    begin
 161       null;
 162    end Finalize_Lock;
 163
 164    ------------------
 165    -- Finalize_TCB --
 166    ------------------
 167
 168    procedure Finalize_TCB (T : Task_Id) is
 169    begin
 170       null;
 171    end Finalize_TCB;
 172
 173    ------------------
 174    -- Get_Priority --
 175    ------------------
 176
 177    function Get_Priority (T : Task_Id) return System.Any_Priority is
 178    begin
 179       return 0;
 180    end Get_Priority;
 181
 182    --------------------
 183    -- Get_Thread_Id  --
 184    --------------------
 185
 186    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
 187    begin
 188       return OSI.Thread_Id (T.Common.LL.Thread);
 189    end Get_Thread_Id;
 190
 191    ----------------
 192    -- Initialize --
 193    ----------------
 194
 195    procedure Initialize (Environment_Task : Task_Id) is
 196    begin
 197       null;
 198    end Initialize;
 199
 200    procedure Initialize (S : in out Suspension_Object) is
 201    begin
 202       null;
 203    end Initialize;
 204
 205    ---------------------
 206    -- Initialize_Lock --
 207    ---------------------
 208
 209    procedure Initialize_Lock
 210      (Prio : System.Any_Priority;
 211       L    : access Lock)
 212    is
 213    begin
 214       null;
 215    end Initialize_Lock;
 216
 217    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 218    begin
 219       null;
 220    end Initialize_Lock;
 221
 222    --------------------
 223    -- Initialize_TCB --
 224    --------------------
 225
 226    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
 227    begin
 228       Succeeded := False;
 229    end Initialize_TCB;
 230
 231    -------------------
 232    -- Is_Valid_Task --
 233    -------------------
 234
 235    function Is_Valid_Task return Boolean is
 236    begin
 237       return False;
 238    end Is_Valid_Task;
 239
 240    --------------
 241    -- Lock_RTS --
 242    --------------
 243
 244    procedure Lock_RTS is
 245    begin
 246       null;
 247    end Lock_RTS;
 248
 249    ---------------------
 250    -- Monotonic_Clock --
 251    ---------------------
 252
 253    function Monotonic_Clock return Duration is
 254    begin
 255       return 0.0;
 256    end Monotonic_Clock;
 257
 258    --------------
 259    -- New_ATCB --
 260    --------------
 261
 262    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
 263    begin
 264       return new Ada_Task_Control_Block (Entry_Num);
 265    end New_ATCB;
 266
 267    ---------------
 268    -- Read_Lock --
 269    ---------------
 270
 271    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 272    begin
 273       Ceiling_Violation := False;
 274    end Read_Lock;
 275
 276    -----------------------------
 277    -- Register_Foreign_Thread --
 278    -----------------------------
 279
 280    function Register_Foreign_Thread return Task_Id is
 281    begin
 282       return null;
 283    end Register_Foreign_Thread;
 284
 285    -----------------
 286    -- Resume_Task --
 287    -----------------
 288
 289    function Resume_Task
 290      (T           : ST.Task_Id;
 291       Thread_Self : OSI.Thread_Id) return Boolean
 292    is
 293    begin
 294       return False;
 295    end Resume_Task;
 296
 297    -------------------
 298    -- RT_Resolution --
 299    -------------------
 300
 301    function RT_Resolution return Duration is
 302    begin
 303       return 10#1.0#E-6;
 304    end RT_Resolution;
 305
 306    ----------
 307    -- Self --
 308    ----------
 309
 310    function Self return Task_Id is
 311    begin
 312       return Null_Task;
 313    end Self;
 314
 315    ---------------
 316    -- Set_False --
 317    ---------------
 318
 319    procedure Set_False (S : in out Suspension_Object) is
 320    begin
 321       null;
 322    end Set_False;
 323
 324    ------------------
 325    -- Set_Priority --
 326    ------------------
 327
 328    procedure Set_Priority
 329      (T                   : Task_Id;
 330       Prio                : System.Any_Priority;
 331       Loss_Of_Inheritance : Boolean := False)
 332    is
 333    begin
 334       null;
 335    end Set_Priority;
 336
 337    --------------
 338    -- Set_True --
 339    --------------
 340
 341    procedure Set_True (S : in out Suspension_Object) is
 342    begin
 343       null;
 344    end Set_True;
 345
 346    -----------
 347    -- Sleep --
 348    -----------
 349
 350    procedure Sleep (Self_ID : Task_Id; Reason  : System.Tasking.Task_States) is
 351    begin
 352       null;
 353    end Sleep;
 354
 355    -----------------
 356    -- Stack_Guard --
 357    -----------------
 358
 359    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
 360    begin
 361       null;
 362    end Stack_Guard;
 363
 364    ------------------
 365    -- Suspend_Task --
 366    ------------------
 367
 368    function Suspend_Task
 369      (T           : ST.Task_Id;
 370       Thread_Self : OSI.Thread_Id) return Boolean
 371    is
 372    begin
 373       return False;
 374    end Suspend_Task;
 375
 376    ------------------------
 377    -- Suspend_Until_True --
 378    ------------------------
 379
 380    procedure Suspend_Until_True (S : in out Suspension_Object) is
 381    begin
 382       null;
 383    end Suspend_Until_True;
 384
 385    -----------------
 386    -- Timed_Delay --
 387    -----------------
 388
 389    procedure Timed_Delay
 390      (Self_ID : Task_Id;
 391       Time    : Duration;
 392       Mode    : ST.Delay_Modes)
 393    is
 394    begin
 395       null;
 396    end Timed_Delay;
 397
 398    -----------------
 399    -- Timed_Sleep --
 400    -----------------
 401
 402    procedure Timed_Sleep
 403      (Self_ID  : Task_Id;
 404       Time     : Duration;
 405       Mode     : ST.Delay_Modes;
 406       Reason   : System.Tasking.Task_States;
 407       Timedout : out Boolean;
 408       Yielded  : out Boolean)
 409    is
 410    begin
 411       Timedout := False;
 412       Yielded := False;
 413    end Timed_Sleep;
 414
 415    ------------
 416    -- Unlock --
 417    ------------
 418
 419    procedure Unlock (L : access Lock) is
 420    begin
 421       null;
 422    end Unlock;
 423
 424    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 425    begin
 426       null;
 427    end Unlock;
 428
 429    procedure Unlock (T : Task_Id) is
 430    begin
 431       null;
 432    end Unlock;
 433
 434    ----------------
 435    -- Unlock_RTS --
 436    ----------------
 437
 438    procedure Unlock_RTS is
 439    begin
 440       null;
 441    end Unlock_RTS;
 442    ------------
 443    -- Wakeup --
 444    ------------
 445
 446    procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
 447    begin
 448       null;
 449    end Wakeup;
 450
 451    ----------------
 452    -- Write_Lock --
 453    ----------------
 454
 455    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 456    begin
 457       Ceiling_Violation := False;
 458    end Write_Lock;
 459
 460    procedure Write_Lock
 461      (L           : access RTS_Lock;
 462       Global_Lock : Boolean := False)
 463    is
 464    begin
 465       null;
 466    end Write_Lock;
 467
 468    procedure Write_Lock (T : Task_Id) is
 469    begin
 470       null;
 471    end Write_Lock;
 472
 473    -----------
 474    -- Yield --
 475    -----------
 476
 477    procedure Yield (Do_Yield : Boolean := True) is
 478    begin
 479       null;
 480    end Yield;
 481
 482 begin
 483    --  Can't raise an exception because target independent packages try to
 484    --  do an Abort_Defer, which gets a memory fault.
 485
 486    No_Tasking :=
 487      System.Error_Reporting.Shutdown
 488        ("Tasking not implemented on this configuration");
 489 end System.Task_Primitives.Operations;