old-autovect-branch/gcc/ada/a-taster.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                 A D A . T A S K _ T E R M I N A T I O N                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2005, Free Software Foundation, Inc.            --
  10 --                                                                          --
  11 -- This specification is derived from the Ada Reference Manual for use with --
  12 -- GNAT. The copyright notice above, and the license provisions that follow --
  13 -- apply solely to the  contents of the part following the private keyword. --
  14 --                                                                          --
  15 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  16 -- terms of the  GNU General Public License as published  by the Free Soft- --
  17 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  18 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  19 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  20 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  21 -- for  more details.  You should have  received  a copy of the GNU General --
  22 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  23 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  24 -- Boston, MA 02110-1301, USA.                                              --
  25 --                                                                          --
  26 -- As a special exception,  if other files  instantiate  generics from this --
  27 -- unit, or you link  this unit with other files  to produce an executable, --
  28 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  29 -- covered  by the  GNU  General  Public  License.  This exception does not --
  30 -- however invalidate  any other reasons why  the executable file  might be --
  31 -- covered by the  GNU Public License.                                      --
  32 --                                                                          --
  33 -- GNAT was originally developed  by the GNAT team at  New York University. --
  34 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  35 --                                                                          --
  36 ------------------------------------------------------------------------------
  37
  38 with System.Tasking;
  39 --  used for Task_Id
  40
  41 with System.Task_Primitives.Operations;
  42 --  used for Self
  43
  44 with Unchecked_Conversion;
  45
  46 package body Ada.Task_Termination is
  47
  48    use type Ada.Task_Identification.Task_Id;
  49
  50    package STPO renames System.Task_Primitives.Operations;
  51
  52    -----------------------
  53    -- Local subprograms --
  54    -----------------------
  55
  56    function To_TT is new Unchecked_Conversion
  57      (System.Tasking.Termination_Handler, Termination_Handler);
  58
  59    function To_ST is new Unchecked_Conversion
  60      (Termination_Handler, System.Tasking.Termination_Handler);
  61
  62    function To_Task_Id is new Unchecked_Conversion
  63      (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id);
  64
  65    -----------------------------------
  66    -- Current_Task_Fallback_Handler --
  67    -----------------------------------
  68
  69    function Current_Task_Fallback_Handler return Termination_Handler is
  70    begin
  71       return To_TT (System.Tasking.Self.Common.Fall_Back_Handler);
  72    end Current_Task_Fallback_Handler;
  73
  74    -------------------------------------
  75    -- Set_Dependents_Fallback_Handler --
  76    -------------------------------------
  77
  78    procedure Set_Dependents_Fallback_Handler
  79      (Handler : Termination_Handler)
  80    is
  81    begin
  82       STPO.Self.Common.Fall_Back_Handler := To_ST (Handler);
  83    end Set_Dependents_Fallback_Handler;
  84
  85    --------------------------
  86    -- Set_Specific_Handler --
  87    --------------------------
  88
  89    procedure Set_Specific_Handler
  90      (T       : Ada.Task_Identification.Task_Id;
  91       Handler : Termination_Handler)
  92    is
  93    begin
  94       --  Tasking_Error is raised if the task identified by T has already
  95       --  terminated. Program_Error is raised if the value of T is
  96       --  Null_Task_Id.
  97
  98       if T = Ada.Task_Identification.Null_Task_Id then
  99          raise Program_Error;
 100       elsif Ada.Task_Identification.Is_Terminated (T) then
 101          raise Tasking_Error;
 102       else
 103          To_Task_Id (T).Common.Specific_Handler := To_ST (Handler);
 104       end if;
 105    end Set_Specific_Handler;
 106
 107    ----------------------
 108    -- Specific_Handler --
 109    ----------------------
 110
 111    function Specific_Handler
 112      (T : Ada.Task_Identification.Task_Id) return Termination_Handler
 113    is
 114    begin
 115       --  Tasking_Error is raised if the task identified by T has already
 116       --  terminated. Program_Error is raised if the value of T is
 117       --  Null_Task_Id.
 118
 119       if T = Ada.Task_Identification.Null_Task_Id then
 120          raise Program_Error;
 121       elsif Ada.Task_Identification.Is_Terminated (T) then
 122          raise Tasking_Error;
 123       else
 124          return To_TT (To_Task_Id (T).Common.Specific_Handler);
 125       end if;
 126    end Specific_Handler;
 127
 128 end Ada.Task_Termination;