------------------------------------------------------------------------------
--                                                                         --
--                GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
--                                                                         --
--              S Y S T E M . T A S K I N G . A B O R T I O N              --
--                                                                         --
--                                 B o d y                                 --
--                                                                         --
--                            $Revision: 1.6 $                             --
--                                                                         --
--          Copyright (c) 1991,1992,1993, FSU, All Rights Reserved         --
--                                                                         --
--  GNARL is free software; you can redistribute it and/or modify it  under --
--  terms  of  the  GNU  Library General Public License as published by the --
--  Free Software Foundation; either version 2,  or (at  your  option)  any --
--  later  version.   GNARL is distributed in the hope that it will be use- --
--  ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
--  MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
--  eral Library Public License for more details.  You should have received --
--  a  copy of the GNU Library General Public License along with GNARL; see --
--  file COPYING. If not, write to the Free Software Foundation,  675  Mass --
--  Ave, Cambridge, MA 02139, USA.                                          --
--                                                                         --
------------------------------------------------------------------------------

with System.Tasking.Runtime_Types;
--  Used for, Runtime_Types.ID_To_ATCB,
--            Runtime_Types.ATCB_To_ID,
--            Runtime_Types.ATCB_Ptr,
--            Runtime_Types.Terminated,
--            Runtime_Types.Not_Accepting,
--            Runtime_Types.All_Tasks_L,
--            Runtime_Types.All_Tasks_List

with System.Tasking.Rendezvous;
--  Used for, Complete_on_Sync_Point

with System.Task_Primitives; use System.Task_Primitives;

package body System.Tasking.Abortion is

   function ID_To_ATCB (ID : Task_ID) return Runtime_Types.ATCB_Ptr
     renames Runtime_Types.ID_To_ATCB;

   function ATCB_To_ID (Ptr : Runtime_Types.ATCB_Ptr) return Task_ID
     renames Runtime_Types.ATCB_To_ID;

   function "=" (L, R : Runtime_Types.Task_Stage) return Boolean
     renames Runtime_Types."=";

   function "=" (L, R : Runtime_Types.ATCB_Ptr) return Boolean
     renames Runtime_Types."=";

   function "=" (L, R : Runtime_Types.Accepting_State) return Boolean
     renames Runtime_Types."=";

   --------------------
   -- Defer_Abortion --
   --------------------

   procedure Defer_Abortion is
      T : Runtime_Types.ATCB_Ptr := ID_To_ATCB (Self);

   begin
      T.Deferral_Level := T.Deferral_Level + 1;
   end Defer_Abortion;

   ----------------------
   -- Undefer_Abortion --
   ----------------------

   --  Precondition : Self does not hold any locks!

   procedure Undefer_Abortion is
      T : Runtime_Types.ATCB_Ptr := ID_To_ATCB (Self);

   begin
      T.Deferral_Level := T.Deferral_Level - 1;

      if T.Deferral_Level = ATC_Level'First and then
        T.Pending_ATC_Level < T.ATC_Nesting_Level
      then
         T.Deferral_Level := T.Deferral_Level + 1; -- go away w/GNARLI 1.28???
         raise Standard'Abort_Signal;
      end if;

   end Undefer_Abortion;

   --------------------
   -- Abort_To_Level --
   --------------------

   procedure Abort_To_Level
     (Target : Task_ID;
      L      : ATC_Level)
   is
      T : Runtime_Types.ATCB_Ptr := ID_To_ATCB (Target);

   begin
      Write_Lock (T.L);

      if T.Pending_ATC_Level > L then
         T.Pending_ATC_Level := L;

         if not T.Aborting then
            T.Aborting := True;

            if T.Suspended_Abortably then
               Cond_Signal (T.Cond);
               Cond_Signal (T.Rend_Cond);

               --  Ugly; think about ways to have tasks suspend on one
               --  condition variable. ???

            else
--               if Same_Task (Target, Self) then    ???

               if Target =  Self then
                  Unlock (T.L);
                  Abort_Task (T.LL_TCB'access);
                  return;

               elsif T.Stage /= Runtime_Types.Terminated then
                  Abort_Task (T.LL_TCB'access);
               end if;

               --  If this task is aborting itself, it should unlock itself
               --  before calling abort, as it is unlikely to have the
               --  opportunity to do so afterwords. On the other hand, if
               --  another task is being aborted, we want to make sure it is
               --  not terminated, since there is no need to abort a terminated
               --  task, and it may be illegal if it has stopped executing.
               --  In this case, the Abort_Task must take place under the
               --  protection of the mutex, so we know that Stage/=Terminated.

            end if;
         end if;
      end if;

      Unlock (T.L);

   end Abort_To_Level;

   -------------------
   -- Abort_Handler --
   -------------------

   procedure Abort_Handler
     (Context : Task_Primitives.Pre_Call_State)
   is
      T : Runtime_Types.ATCB_Ptr := ID_To_ATCB (Self);

   begin
      if T.Deferral_Level = 0
        and then T.Pending_ATC_Level < T.ATC_Nesting_Level
      then
         raise Standard'Abort_Signal;

         --  Not a good idea; signal remains masked after the Abortion ???
         --  exception is handled.  There are a number of solutions :
         --  1. Change the PC to point to code that raises the exception and
         --     then jumps to the location that was interrupted.
         --  2. Longjump to the code that raises the exception.
         --  3. Unmask the signal in the Abortion exception handler
         --     (in the RTS).
      end if;
   end Abort_Handler;

   ----------------------
   -- Abort_Dependents --
   ----------------------

   --  Process abortion of child tasks.

   --  Abortion should be dererred when calling this routine.
   --  No mutexes should be locked when calling this routine.

   procedure Abort_Dependents (Abortee : Task_ID) is
      Temp_T                : Runtime_Types.ATCB_Ptr;
      Temp_P                : Runtime_Types.ATCB_Ptr;
      Old_Pending_ATC_Level : ATC_Level_Base;
      TAS_Result            : Boolean;
      A                     : Runtime_Types.ATCB_Ptr := ID_To_ATCB (Abortee);

   begin
      Write_Lock (Runtime_Types.All_Tasks_L);
      Temp_T := Runtime_Types.All_Tasks_List;

      while Temp_T /= null loop
         Temp_P := Temp_T.Parent;

         while Temp_P /= null loop
            exit when Temp_P = A;
            Temp_P := Temp_P.Parent;
         end loop;

         if Temp_P = A then
            Temp_T.Accepting := Runtime_Types.Not_Accepting;

            --  Send cancel signal.
            Rendezvous.Complete_on_Sync_Point (ATCB_To_ID (Temp_T));
            Abort_To_Level (ATCB_To_ID (Temp_T), 0);
         end if;

         Temp_T := Temp_T.All_Tasks_Link;
      end loop;

      Unlock (Runtime_Types.All_Tasks_L);

   end Abort_Dependents;

   -----------------
   -- Abort_Tasks --
   -----------------

   --  Called to initiate abortion, however, the actual abortion
   --  is done by abortee by means of Abort_Handler

   procedure Abort_Tasks (Tasks : Task_List) is
      Abortee               : Runtime_Types.ATCB_Ptr;
      Aborter               : Runtime_Types.ATCB_Ptr;
      Activator             : Runtime_Types.ATCB_Ptr;
      TAS_Result            : Boolean;
      Old_Pending_ATC_Level : ATC_Level_Base;

   begin
      Defer_Abortion;

      --  Begin non-abortable section

      Aborter := ID_To_ATCB (Self);

      for J in Tasks'range loop
         Abortee := ID_To_ATCB (Tasks (J));
         Abortee.Accepting := Runtime_Types.Not_Accepting;
         Rendezvous.Complete_on_Sync_Point (ATCB_To_ID (Abortee));
         Abort_To_Level (ATCB_To_ID (Abortee), 0);

         --  Process abortion of child tasks

         Abort_Dependents (ATCB_To_ID (Abortee));

      end loop;

      --  End non-abortable section

      Undefer_Abortion;
   end Abort_Tasks;

end System.Tasking.Abortion;
