--------------------------------------------------------------------------------
--                                                                            --
-- Copyright (C) 2004, RISC OS Ada Library (RASCAL) developers.               --
--                                                                            --
-- This library is free software; you can redistribute it and/or              --
-- modify it under the terms of the GNU Lesser General Public                 --
-- License as published by the Free Software Foundation; either               --
-- version 2.1 of the License, or (at your option) any later version.         --
--                                                                            --
-- This library is distributed in the hope that it will be useful,            --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of             --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU           --
-- Lesser General Public License for more details.                            --
--                                                                            --
-- You should have received a copy of the GNU Lesser General Public           --
-- License along with this library; if not, write to the Free Software        --
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA    --
--                                                                            --
--------------------------------------------------------------------------------

-- $Author$
-- $Date$
-- $Revision$

with RASCAL.MessageTrans;     use RASCAL.MessageTrans;
with RASCAL.Memory;           use RASCAL.Memory;

with Ada.Strings.Unbounded;   use Ada.Strings.Unbounded;
with Interfaces.C;            use Interfaces.C;
with System.Storage_Elements; use System.Storage_Elements;
with Kernel;                  use Kernel;
with Ada.Exceptions;          use Ada.Exceptions;
with Unchecked_Deallocation;


package body RASCAL.ToolboxTask is

   procedure Free_HandlerArray is new Unchecked_Deallocation
                                        (Handler_Array, HandlerArray_Pointer);

   procedure Free_HandlerArrayHeader is new Unchecked_Deallocation
                                        (HandlerArray_Header, HandlerArrayHeader_Pointer);

   procedure Free_EventArray is new Unchecked_Deallocation
                                        (Event_Array, EventArray_Pointer);

   procedure Free_EventArrayHeader is new Unchecked_Deallocation
                                        (EventArray_Header, EventArrayHeader_Pointer);

   procedure Free_EventList is new Unchecked_Deallocation
                                 (ToolBox_Event_List_Type, ToolBox_Event_List_Pointer);

   procedure Delete_Handler (The    : in Toolbox_Task_Pointer;
                             Events : in HandlerArrayHeader_Pointer);

   procedure Delete_Handler (Handlers : in HandlerArrayHeader_Pointer;
                             Listener : in Event_Pointer);

   --
   -- Remove wimp event listener.
   --
   procedure Remove_WimpListener (The      : in Toolbox_Task_Pointer;
                                  Listener : in Event_Pointer);

   --
   -- Removes message event listener.
   --
   procedure Remove_MessageListener (The      : in Toolbox_Task_Pointer;
                                     Listener : in Event_Pointer);

   --
   -- Add wimp event listener.
   --
   procedure Add_WimpListener (The      : in Toolbox_Task_Pointer;
                               Listener : in Event_Pointer);

   procedure Add_ToolboxListener (The      : in ToolBox_Task_Pointer;
                                  Listener : in Event_Pointer);

   --
   -- Add message event listener.
   --
   procedure Add_MessageListener (The      : in Toolbox_Task_Pointer;
                                  Listener : in Event_Pointer);

   procedure Add (Events   : in EventArrayHeader_Pointer;
                  Handlers : in HandlerArrayHeader_Pointer);

   procedure Add (Handlers : in HandlerArrayHeader_Pointer;
                  Handler  : in Event_Pointer);

   procedure Dispatch (The         : in Toolbox_Task_Pointer;
                       Reason_Code : in Reason_Event_Code_Type;
                       Window      : in Wimp_Handle_Type;
                       Icon        : in Icon_Handle_Type);

   procedure Dispatch (The : in Toolbox_Task_Pointer;
                       Message_Code : in Message_Event_Code_Type);

   procedure Dispatch (The : in Toolbox_Task_Pointer;
                       Reason_Code : in ToolBox_Event_Code_Type);

   function Find_Handler (The : in Toolbox_Task_Pointer;
                          Reason_Code : in ToolBox_Event_Code_Type) return HandlerArrayHeader_Pointer;

   function Find_Handler (The : in Toolbox_Task_Pointer;
                          Reason_Code : in Reason_Event_Code_Type) return HandlerArrayHeader_Pointer;

   function Find_Handler (The : in Toolbox_Task_Pointer;
                          Message_Code : in Message_Event_Code_Type) return HandlerArrayHeader_Pointer;

   --

   procedure Initialise (The : in ToolBox_Task_Pointer) is

      ToolBox_Initialise : constant := 16#44ECF#;
      Register           : aliased Kernel.swi_regs;
      Path               : String(To_String(The.all.Res_Path)'first..To_String(The.all.Res_Path)'last+1):= To_String(The.all.Res_Path) & Character'Val(0);
      M                  : Messages_List_Pointer := Get_Messages(The);
      TaskName           : Unbounded_String;
      Error              : oserror_access;
   begin
      if Length(The.all.Res_Path) = 0 then
         Raise_Exception(No_Toolbox_Res_Path'Identity,"No Toolbox Res Path");
      end if;

      -- Init task
      Register.R(0) := int(0);
      Register.R(1) := int(350);
      Register.R(2) := Adr_To_Int(M.all'Address);
      Register.R(3) := Adr_To_Int(The.all.TB_Wanted_Events.all'Address);
      Register.R(4) := Adr_To_Int(Path'Address);
      Register.R(5) := Adr_To_Int(Get_Message_Block(The).all'Address);
      Register.R(6) := Adr_To_Int(The.all.TB_Block.all'Address);
      Error := Kernel.Swi (ToolBox_Initialise, Register'Access, Register'Access);

      if Error /= null then
         pragma Debug(Report("ToolboxTask.Initialise: " & To_Ada(Error.errmess)));
         OS.Raise_Error(Error);
      else
         Set_Status (The,true);
         Get_Message_Block (The).all(5) := 1;
         Set_Wimp_Version (The,Wimp_Version_Type(Register.R(0)));
         Set_Task_Handle (The,Task_Handle_Type(Register.R(1)));
         Set_Sprite_Area (The,System_Sprite_Pointer(Int_To_Adr(Register.R(2))));
         TaskName :=   U(MessageTrans.Lookup("_TaskName" & Character'Val(0),Get_Message_Block(The)));
         Set_Name (The,S(TaskName));
         Get_Error (The).all.Msg_Handle := Get_Message_Block(The);
         Get_Error (The).all.Task_Name  := U(Get_Name(The));
      end if;
   end Initialise;

   --

   procedure Single_Poll (The : in Toolbox_Task_Pointer;
                          Mask: in Integer := 0) is

      Block       : Wimp_Block_Pointer := Get_Wimp_Block(The);
      Wimp_Poll   : constant           := 16#400C7#;
      Register    : aliased Kernel.swi_regs;
      Reason_Code : integer;
      Error       : oserror_access;
   begin
      Register.R (0) := int(Mask);
      Register.R (1) := int (To_Integer (The.all.Wimp_Block (0)'Address));
      Error := Kernel.SWI (Wimp_Poll, Register'Access, Register'Access);

      if Error = null then
         Reason_Code := integer (Register.R (0));
         
         case Reason_Code is
         when 17 | 18 | 19 => Dispatch (The,Message_Event_Code_Type (The.all.Wimp_Block (4)));
         when 16#200#      => Dispatch (The,Toolbox_Event_Code_Type(Block(2)));
         when others       => Dispatch (The, Reason_Event_Code_Type (Reason_Code),
                                        Wimp_Handle_Type (The.all.Wimp_Block (0)),
                                        Icon_Handle_Type (The.all.Wimp_Block (1)));
         end case;
      else
         pragma Debug(Report("WimpTask.SinglePoll: " & To_Ada(Error.errmess)));
         OS.Raise_Error(Error);
      end if;
   end Single_Poll;

   --

   procedure Poll (The : in Toolbox_Task_Pointer) is

      Wimp_Poll     : constant := 16#400C7#;
      Wimp_PollIdle : constant := 16#400E1#;
      Register      : aliased Kernel.swi_regs;
      Reason_code   : integer;   
      Block         : Wimp_Block_Pointer := Get_Wimp_Block(The);
      Error         : oserror_access;
      Listener      : Event_Pointer;
   begin
      while Get_Status(The) loop

         if The.all.Deleted_Events.all.Current_Index > 1 then
            for i in 1..The.all.Deleted_Events.all.Current_Index-1 loop
               Listener := The.all.Deleted_Events.all.Handlers(i);
               case Listener.all.Kind is
               when Wimp    => Remove_WimpListener (The,Listener);
               when Message => Remove_MessageListener (The,Listener);
               when others  => Raise_Exception(Unknown_Deleted_Event'Identity,"Unknown Deleted Event");
               end case;
               Delete_Handler (The.all.Deleted_Events,Listener);
            end loop;
         end if;
         Register.R(0) := int(Get_Poll_Mask(The));
         Register.R(1) := Adr_To_Int(Block.all(0)'Address);
         if The.all.WakeUpTime = 0 then
            Error := Kernel.swi (Wimp_Poll, Register'Access, Register'Access);
         else
            Register.R(2) := int(The.all.WakeUpTime);
            Error := Kernel.swi (Wimp_PollIdle, Register'Access, Register'Access);
         end if;
         if Error = null then
            Reason_Code := integer(Register.R(0));
            case Reason_Code is
            when 17 | 18 | 19 => Dispatch(The,Message_Event_Code_Type(Block(4)));
            when 16#200#      => Dispatch(The,Toolbox_Event_Code_Type(Block(2)));
            when others       => Dispatch(The,Reason_Event_Code_Type(Reason_Code),Wimp_Handle_Type(Block(0)),Icon_Handle_Type(Block(1)));
            end case;
         else
            pragma Debug(Report("WimpTask.Poll: " & To_Ada(Error.errmess)));
            OS.Raise_Error(Error);
         end if;
      end loop;
   end Poll;


--  Event handling

   procedure Add_Listener (The      : in Toolbox_Task_Pointer;
                           Listener : in Event_Pointer) is
   begin
   pragma Debug(Report ("a2"));

      case Listener.all.Kind is
      when Wimp    => Add_WimpListener (The,Listener);
      when Message => Add_MessageListener (The,Listener);
      when others  => Add_ToolboxListener (The,Listener);
      end case;
   end Add_Listener;

   --

   procedure Remove_Listener (The      : in Toolbox_Task_Pointer;
                              Listener : in Event_Pointer) is
   begin
      case Listener.all.Kind is
      when Wimp | Message => Add(The.all.Deleted_Events,Listener);
      when Others         => Raise_Exception(Is_Toolbox_Event'Identity,"Event Is Toolbox Event");
      end case;
   end Remove_Listener;

   --

   procedure Add_ToolboxListener (The      : in ToolBox_Task_Pointer;
                                  Listener : in Event_Pointer) is

      Handlers     : HandlerArrayHeader_Pointer;
      Reason_Code  : Toolbox_Event_Code_Type := Toolbox_EventListener(Listener.all).Event_Code;
      Block        : Wimp_Block_Pointer      := Get_Wimp_Block(The);
      NewArray     : ToolBox_Event_List_Pointer;
   begin
      if Get_Status(The) then
         Raise_Exception(After_Task_Init'Identity,"Toolbox Event Added After Task Init");
      end if;
      -- Initialise ID_Block pointer
      Toolbox_EventListener(Listener.all).ID_Block := The.all.TB_Block;

      -- Update Event pointer
      Memory.PutWord(Adr_To_Integer (Block.all'Address),
                     ToolBox_EventListener(Listener.all).ID_Block'Address,4);

      Handlers := Find_Handler(The,Reason_Code) ;
      if Handlers = null then
         Handlers := new HandlerArray_Header;
         Handlers.all.Event_Code := integer(Reason_Code);
         Add(The.all.TB_Event_Handlers,Handlers);
         if Number_of_Toolbox_Events > Max_Number_of_Toolbox_Events then
            NewArray := new ToolBox_Event_List_Type(0..2*The.all.TB_Wanted_Events.all'Length);
            for i in The.all.TB_Wanted_Events.all'range loop
               NewArray.all(i) := The.all.TB_Wanted_Events.all(i);
            end loop;
            Free_EventList(The.all.TB_Wanted_Events);
            The.all.TB_Wanted_Events := NewArray;
            Max_Number_of_Toolbox_Events := NewArray'Length;
         end if;
         The.all.TB_Wanted_Events(Number_of_Toolbox_Events) := integer(Reason_Code);
         Number_of_Toolbox_Events := Number_of_Toolbox_Events + 1;
      end if;
      Add(Handlers,Listener);
   end Add_ToolboxListener;

   --

   procedure Add_WimpListener (The      : in Toolbox_Task_Pointer;
                               Listener : in Event_Pointer) is

      Handlers    : HandlerArrayHeader_Pointer;
      Reason_Code : Reason_Event_Code_Type :=
                    Wimp_EventListener (Listener.all).Event_Code;
      Block       : Wimp_Block_Pointer := Get_Wimp_Block(The);
   begin
      -- Initialise Event pointer
      Memory.PutWord(Adr_To_Integer (Block.all'Address),
                     Wimp_EventListener(Listener.all).Icon'Address,4);

      Handlers := Find_Handler (The, Reason_Code);
      if Handlers = null then
         Handlers := new HandlerArray_Header;
         Handlers.Event_Code := integer (Reason_Code);
         
         Add (The.all.Events, Handlers);
         case Reason_Code is
         when Reason_Event_NullReason | Reason_Event_RedrawWindow |
              Reason_Event_PointerLeavingWindow | Reason_Event_PointerEnteringWindow |
              Reason_Event_MouseClick | Reason_Event_KeyPressed | Reason_Event_LoseCaret |
              Reason_Event_GainCaret | Reason_Event_PollWordNonZero |
              Reason_Event_UserMessage | Reason_Event_UserMessageRecorded |
              Reason_Event_UserMessageAcknowledge | 22 | 23 | 24 => Change_Mask (The, 2**integer (Reason_Code), false);
         when others => null;
         end case;
      end if;
      Add (Handlers, Listener);
   end Add_WimpListener;

   --

   procedure Remove_WimpListener (The : in Toolbox_Task_Pointer;
                                  Listener : in Event_Pointer) is

      Handlers    : HandlerArrayHeader_Pointer;
      Reason_Code : Reason_Event_Code_Type :=
                    Wimp_EventListener (Listener.all).Event_Code;
   begin
      Handlers := Find_Handler (The, Reason_Code);
      if Handlers /= null then
         Delete_Handler(Handlers,Listener);
         --  Remove reason if there are no handlers
         if Handlers.all.Current_Index <= 1 then
            --  Update mask
            Change_Mask (The, 2**integer (Reason_Code));
            Delete_Handler(The,Handlers);
         end if;
      end if;
   end Remove_WimpListener;

   --

   procedure Add_MessageListener (The      : in Toolbox_Task_Pointer;
                                  Listener : in Event_Pointer) is

      Handlers         : HandlerArrayHeader_Pointer;
      Buffer           : array (1 .. 2) of integer;
      Wimp_AddMessages : constant := 16#400F6#;
      Register         : aliased Kernel.swi_regs;
      Error            : oserror_access;
      Block            : Wimp_Block_Pointer := Get_Wimp_Block(The);
      Reason_Code      : Message_Event_Code_Type
                       := Message_EventListener (Listener.all).Event_Code;
   begin
      -- Initialise event pointer
      Memory.PutWord(Adr_To_Integer (Block.all'Address),
                     Message_EventListener(Listener.all).Event_Code'Address,4);

      Handlers := Find_Handler (The, Reason_Code);
      if Handlers = null then
         Handlers := new HandlerArray_Header;
         Handlers.Event_Code := integer (Reason_Code);
         
         Add (The.all.Msg_Events, Handlers);

         The.all.Messages (Number_Of_Messages) := integer (Reason_Code);

         -- Ensure message '0' is the last message in the array.
         if (Number_Of_Messages > 0) and then
            (The.all.Messages (Number_Of_Messages-1) = 0) then

            The.all.Messages (Number_Of_Messages-1) := The.all.Messages (Number_Of_Messages);
            The.all.Messages (Number_Of_Messages)   := 0;
         end if;   
         Number_Of_Messages := Number_Of_Messages + 1;
         --  If task is running...
         if Get_Status (The) then
            Buffer (1) := integer (Reason_Code);
            Buffer (2) := 0;
            Register.R (0) := int (To_Integer (Buffer (1)'Address));
            Error := Kernel.SWI (Wimp_AddMessages, Register'Access, Register'Access);
            if Error /= null then
               pragma Debug(Report("WimpTask.: Add_MessageListener" & To_Ada(Error.ErrMess)));
               OS.Raise_Error(Error);
            end if;
         end if;
      end if;
      Add (Handlers, Listener);
   end Add_MessageListener;

   --

   procedure Remove_MessageListener (The      : in Toolbox_Task_Pointer;
                                     Listener : in Event_Pointer) is

      Handlers            : HandlerArrayHeader_Pointer;
      Buffer              : array (1 .. 2) of integer;
      Wimp_RemoveMessages : constant := 16#400F7#;
      Register            : aliased Kernel.swi_regs;
      Error               : oserror_access;
      Reason_Code         : Message_Event_Code_Type
                          := Message_EventListener (Listener.all).Event_Code;
   begin
      Handlers := Find_Handler (The, Reason_Code);
      if Handlers /= null then
         if Handlers.all.Current_Index > 1 then
            for i in 1..Handlers.all.Current_Index-1 loop
               if Handlers.all.Handlers(i) = Listener then
                  Handlers.all.Handlers(i) := Handlers.all.Handlers(The.all.Events.all.Current_Index-1);
                  Handlers.all.Handlers(The.all.Events.all.Current_Index-1) := null;
                  Handlers.all.Current_Index := Handlers.all.Current_Index - 1;
                  exit;
               end if;
            end loop;
         end if;
         --  Remove message if there are no handlers
         if Handlers.all.Current_Index <= 1 then
            Buffer (1) := integer (Reason_Code);
            Buffer (2) := 0;
            Register.R (0) := int (To_Integer (Buffer (1)'Address));
            Error := Kernel.SWI (Wimp_RemoveMessages, Register'Access,Register'Access);
            if Error /= null then
               pragma Debug(Report("WimpTask.: Remove_MessageListener" & To_Ada(Error.ErrMess)));
               OS.Raise_Error(Error);
            end if;
            Delete_Handler(The,Handlers);
         end if;
      end if;
   end Remove_MessageListener;
   
   --

   procedure Dispatch (The         : in Toolbox_Task_Pointer;
                       Reason_Code : in Reason_Event_Code_Type;
                       Window      : in Wimp_Handle_Type;
                       Icon        : in Icon_Handle_Type) is

      Handlers : HandlerArrayHeader_Pointer;
      Handler  : Event_Pointer;
      W        : Wimp_Handle_Type;
      Ic       : Icon_Handle_Type;
   begin
      Handlers := Find_Handler (The, Reason_Code);
      if Handlers /= null then
         if Handlers.all.Current_Index > 1 then
            for i in 1..Handlers.all.Current_Index-1 loop
               Handler := Handlers.all.Handlers(i);
               W := Wimp_EventListener (Handler.all).Window;
               Ic := Wimp_EventListener (Handler.all).Icon;
               if (W = Window or W = -1) then
                  if (Ic = Icon or Ic = -1) then
                     Handle (Handler.all);
                  end if;
               end if;
            end loop;
         end if;
      end if;
   end Dispatch;

   --

   procedure Dispatch (The : in Toolbox_Task_Pointer;
                       Message_Code : in Message_Event_Code_Type) is

      Handlers : HandlerArrayHeader_Pointer;
   begin
      Handlers := Find_Handler (The, Message_Code);
      if Handlers /= null then
         if Handlers.all.Current_Index > 1 then
            for i in 1..Handlers.all.Current_Index-1 loop
               Handle (Handlers.all.Handlers(i).all);
            end loop;
         end if;
      end if;
   end Dispatch;

   --

   procedure Dispatch (The : in Toolbox_Task_Pointer;
                       Reason_Code : in ToolBox_Event_Code_Type) is

      Object    : constant Object_ID    := Get_Self_Id(The);
      Component : constant Component_ID := Get_Self_Component(The);
      O         : Object_ID;
      C         : Component_ID;
      Handlers  : HandlerArrayHeader_Pointer;
      Handler   : Event_Pointer;
   begin
      Handlers := Find_Handler(The,Reason_Code);
      if Handlers /= null then
         if Handlers.all.Current_Index > 1 then
            for i in 1..Handlers.all.Current_Index-1 loop
               Handler := Handlers.all.Handlers(i);
               O := Object_ID(ToolBox_EventListener(Handler.all).Object);
               C := Component_ID(ToolBox_EventListener(Handler.all).Component);
               if (O = Object or O = -1) then
                  if (C = Component or C = -1) then
                     Handle(Handler.all);
                  end if;
               end if;
            end loop;
         end if;
      end if;
   end Dispatch;

--  Get methods

   function Get_Message_Block (The : in Toolbox_Task_Pointer)
                                       return Messages_Handle_Type is
   begin
      return The.all.Msg_Block;
   end Get_Message_Block;

   --

   function Get_Wimp_Version (The : in Toolbox_Task_Pointer)
                                       return Wimp_Version_Type is
   begin
      return The.all.Wimp_Nr;
   end Get_Wimp_Version;

   --

   function Get_Task_Handle (The : in Toolbox_Task_Pointer)
                                       return Task_Handle_Type is
   begin
      return The.all.Task_Handle;
   end Get_Task_Handle;

   --

   function Get_Name (The : in Toolbox_Task_Pointer) return String is
   begin
      return The.all.Task_Name;
   end Get_Name;

   --

   function Get_Wimp_Block (The : in Toolbox_Task_Pointer)
                                       return Wimp_Block_Pointer is
   begin
      return The.all.Wimp_Block;
   end Get_Wimp_Block;

   --

   function Get_Status (The : in Toolbox_Task_Pointer)
                                       return Task_Status_Type is
   begin
      return The.all.Continue;
   end Get_Status;

   --

   function Get_Poll_Mask (The : in Toolbox_Task_Pointer)
                                       return Poll_Mask_Type is
   begin
      return The.all.Mask;
   end Get_Poll_Mask;

   --

   function Get_WakeUp_Time (The  : in Toolbox_Task_Pointer) return Integer is
   begin
      return The.all.WakeUpTime;
   end Get_WakeUp_Time;

   --

   function Get_Error (The : in Toolbox_Task_Pointer) return Error.Error_Pointer is
   begin
      return The.all.Error;
   end Get_Error;

   --
   
   function Get_Resources_Path (The : in Toolbox_Task_Pointer) return String is
   begin
      return To_String(The.all.Res_Path);
   end Get_Resources_Path;

   --

   function Get_Self_Id (The : in Toolbox_Task_Pointer) return Object_ID is
   begin
      return The.all.TB_Block.all.Self_Id;
   end Get_Self_Id;

   --

   function Get_Self_Component (The : in Toolbox_Task_Pointer) return Component_ID is
   begin
      return The.all.TB_Block.all.Self_Component;
   end Get_Self_Component;

   --

   function Get_Parent_Id (The : in Toolbox_Task_Pointer) return Object_ID is
   begin
      return The.all.TB_Block.all.Parent_Id;
   end Get_Parent_Id;

   --

   function Get_Parent_Component (The : in Toolbox_Task_Pointer) return Component_ID is
   begin
      return The.all.TB_Block.all.Parent_Component;
   end Get_Parent_Component;

   --

   function Get_Ancestor_Id (The : in Toolbox_Task_Pointer) return Object_ID is
   begin
      return The.all.TB_Block.all.Ancestor_Id;
   end Get_Ancestor_Id;

   --

   function Get_Ancestor_Component (The : in Toolbox_Task_Pointer) return Component_ID is
   begin
      return The.all.TB_Block.all.Ancestor_Component;
   end Get_Ancestor_Component;

   --

   function Get_Sprite_Area (The : in Toolbox_Task_Pointer) return System_Sprite_Pointer is
   begin
      return The.all.Sprite_Area;
   end Get_Sprite_Area;

--  Set methods

   procedure Set_Resources_Path (The  : in ToolBox_Task_Pointer;
                                 Path : in String) is
   begin
      The.all.Res_Path := To_Unbounded_String(Path);
   end Set_Resources_Path;

   --

   procedure Set_Sprite_Area (The : in Toolbox_Task_Pointer;
                              Area: in System_Sprite_Pointer) is
   begin
      The.all.Sprite_Area:=Area;
   end Set_Sprite_Area;

   --
   
   procedure Set_Wimp_Version (The : in Toolbox_Task_Pointer;
                               Nr  : in Wimp_Version_Type) is
   begin
      The.all.Wimp_Nr := Nr;
   end Set_Wimp_Version;

   --

   procedure Set_Task_Handle (The      : in Toolbox_Task_Pointer;
                              Handle   : in Task_Handle_Type) is
   begin
      The.all.Task_Handle := Handle;
   end Set_Task_Handle;

   --

   procedure Set_Name (The  : in Toolbox_Task_Pointer;
                       Name : in String) is

      First : Integer := The.all.Task_Name'First;
      Last  : Integer := The.all.Task_Name'First+Name'Length-1;
   begin
      if Name'Length < The.all.Task_Name'Length then
         The.all.Task_Name(First..Last) := Name;
      else
         The.all.Task_Name(The.all.Task_Name'First..(The.all.Task_Name'Last)) := Name;
      end if;
   end Set_Name;

   --

   procedure Set_Status (The    : in Toolbox_Task_Pointer;
                         Status : in Task_Status_Type) is
   begin
      The.all.Continue := Status;
   end Set_Status;

   --

   procedure Set_Poll_Mask (The       : in Toolbox_Task_Pointer;
                            Poll_Mask : in Poll_Mask_Type) is
   begin
      The.all.Mask := Poll_Mask;
   end Set_Poll_Mask;

   --

   procedure Set_WakeUp_Time (The  : in Toolbox_Task_Pointer;
                              Time : in Integer) is
   begin
      The.all.WakeUpTime := Time;
   end Set_WakeUp_Time;

   --

   function Get_Messages (The : in Toolbox_Task_Pointer)
                                 return Messages_List_Pointer is
   begin
      return The.all.Messages;
   end Get_Messages;

--  Misc

   procedure Add (Handlers : in HandlerArrayHeader_Pointer;
                  Handler  : in Event_Pointer) is

      NewArray : HandlerArray_Pointer;
   begin
      if Handlers.Current_Index > Handlers.Handlers.all'Last then
         NewArray := new Handler_Array(1..(2*Handlers.all.Current_Index));
         for i in Handlers.Handlers.all'Range loop
            NewArray.all(i) := Handlers.Handlers.all(i);
         end loop;
         Free_HandlerArray(Handlers.Handlers);
         Handlers.Handlers := NewArray;
      end if;
      Handlers.all.Handlers.all(Handlers.all.Current_Index) := Handler;
      Handlers.all.Current_Index := Handlers.all.Current_Index + 1;
   end Add;

   --
   
   procedure Add (Events   : in EventArrayHeader_Pointer;
                  Handlers : in HandlerArrayHeader_Pointer) is

      NewArray : EventArray_Pointer;
   begin
      if Events.all.Current_Index > Events.all.Events.all'Last then
         NewArray := new Event_Array(1..(2*Events.all.Current_Index));
         for i in Events.all.Events.all'range loop
            NewArray(i) := Events.all.Events.all(i);
         end loop;
         Free_EventArray(Events.Events);
         Events.all.Events := NewArray;
      end if;
      Events.all.Events.all (Events.all.Current_Index) := Handlers;
      Events.all.Current_Index := Events.all.Current_Index + 1;
   end Add;

   --

   function Find_Handler (The : in Toolbox_Task_Pointer;
                          Reason_Code : in ToolBox_Event_Code_Type) return HandlerArrayHeader_Pointer is
   begin
     if The.all.TB_Event_Handlers.all.Current_Index > 1 then
        for i in 1..(The.all.TB_Event_Handlers.all.Current_Index-1) loop
           if  The.all.TB_Event_Handlers.all.Events(i).Event_Code = integer(Reason_Code) then
              return The.all.TB_Event_Handlers.all.Events(i);
           end if;
        end loop;
     end if;
     return null;
   end Find_Handler;

   --

   function Find_Handler (The : in Toolbox_Task_Pointer;
                          Reason_Code : in Reason_Event_Code_Type) return HandlerArrayHeader_Pointer is
   begin
     if The.all.Events.all.Current_Index > 1 then
        for i in 1..(The.all.Events.all.Current_Index-1) loop
           if The.all.Events.all.Events(i).Event_Code = integer(Reason_Code) then
              return The.all.Events.all.Events(i);
           end if;
        end loop;
     end if;
     return null;
   end Find_Handler;

   --

   function Find_Handler (The : in Toolbox_Task_Pointer;
                          Message_Code : in Message_Event_Code_Type) return HandlerArrayHeader_Pointer is
   begin
      if The.all.Msg_Events.all.Current_Index > 1 then
         for i in 1..(The.all.Msg_Events.all.Current_Index-1) loop
            if The.all.Msg_Events.all.Events(i).Event_Code = integer(Message_Code) then
               return The.all.Msg_Events.all.Events(i);
            end if;
         end loop;
      end if;
      return null;
   end Find_Handler;

   --

   procedure Delete_Handler (Handlers : in HandlerArrayHeader_Pointer;
                             Listener : in Event_Pointer) is

      Handler     : Event_Pointer;
   begin
      if Handlers.all.Current_Index > 1 then
         for i in 1..Handlers.all.Current_Index-1 loop
            Handler := Handlers.all.Handlers(i);
            if Handler = Listener then
               Handlers.all.Handlers(i)   := Handlers.all.Handlers(Handlers.all.Current_Index-1);
               Handlers.all.Current_Index := Handlers.all.Current_Index - 1;
               exit;
            end if;
         end loop;
      end if;
   end Delete_Handler;

   --

   procedure Delete_Handler (The    : in Toolbox_Task_Pointer;
                             Events : in HandlerArrayHeader_Pointer) is
   begin
     if The.all.Events.all.Current_Index > 1 then
        for i in 1..(The.all.Events.all.Current_Index-1) loop
           if The.all.Events.all.Events(i) = Events then
              Free_HandlerArray(The.all.Events.all.Events(i).Handlers);
              Free_HandlerArrayHeader(The.all.Events.all.Events(i));
              The.all.Events.all.Events(i) := The.all.Events.all.Events(The.all.Events.all.Current_Index-1);
              The.all.Events.all.Events(The.all.Events.all.Current_Index-1) := null;
              The.all.Events.all.Current_Index := The.all.Events.all.Current_Index - 1;
           end if;
        end loop;
     end if;
   end Delete_Handler;

   --


   procedure Change_Mask (The   : in Toolbox_Task_Pointer;
                          Value : in unsigned;
                          Set   : in Boolean := true) is

      New_Mask : Poll_Mask_Type := Get_Poll_Mask (The);
   begin
      if Set then
         New_Mask := New_Mask or Value;
      else
         New_Mask := New_Mask and (not Value);
      end if;
      Set_Poll_Mask (The, New_Mask);
   end Change_Mask;

   --

   procedure Set_Error (The : in Toolbox_Task_Pointer;
                        E   : in Error_Pointer) is
   begin
      The.all.Error := E;
   end Set_Error;

   --

   procedure Report_ID_Block (The : in Toolbox_Task_Pointer) is
   begin
      pragma Debug(Report("Ancestor_ID: " & intstr(integer(The.all.TB_Block.all.Ancestor_ID))));
      null; pragma Debug(Report("Ancestor_Component: " & intstr(integer(The.all.TB_Block.all.Ancestor_Component))));
      pragma Debug(Report("Parent_ID: " & intstr(integer(The.all.TB_Block.all.Parent_ID))));
      pragma Debug(Report("Parent_Component: " & intstr(integer(The.all.TB_Block.all.Parent_Component))));
      pragma Debug(Report("Self_ID: " & intstr(integer(The.all.TB_Block.all.Self_ID))));
      pragma Debug(Report("Self_Component: " & intstr(integer(The.all.TB_Block.all.Self_Component))));
   end Report_ID_Block;

   --
    
end RASCAL.ToolboxTask;
