--------------------------------------------------------------------------------
--                                                                            --
-- 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 Kernel;                    use Kernel;
with Interfaces.C;              use Interfaces.C;
with System.Storage_Elements;   use System.Storage_Elements;
with System;                    use System;


with RASCAL.Utility;            use RASCAL.Utility;
with RASCAL.OS;

with Ada.Unchecked_Deallocation;

package body RASCAL.DynamicArea is

   procedure Destroy is
      new Ada.Unchecked_Deallocation (Dynamic_Area_Type, Dynamic_Area_Ptr);

   --

   Dynamic_Area_System_Heap    : constant := 0;
   Dynamic_Area_RMA            : constant := 1;
   Dynamic_Area_Screen_Memory  : constant := 2;
   Dynamic_Area_System_Sprites : constant := 3;
   Dynamic_Area_Font_Cache     : constant := 4;
   Dynamic_Area_RAM_Disc       : constant := 5;
   Dynamic_Area_Free_Pool      : constant := 6;

   --

   procedure Create(Area       : in out Dynamic_Area_Type;
                    Name       : in String;
                    Start_Size : in Integer := 0;
                    Max_Size   : in Integer := 32*1024*1024;
                    Flags      : in Integer := Default_Flags) is

     Error    : Kernel.OSError_access;
     Register : aliased Kernel.SWI_regs;
     Name_0   : String(1..32);
     Len      : Natural := Name'Length;
   begin
      if Len > 31 then
         Len := 31;
      end if;

      Area.Name(Area.Name'First..Len) := Name(Name'First..Len);
      Name_0(1..Len) := Name(1..Len);
      Name_0(Len+1)  := ASCII.NUL;
      Area.Flags := Flags;

      Register.R(0) := 0;
      Register.R(1) := -1;
      Register.R(2) := int(Start_Size);
      Register.R(3) := -1;
      Register.R(4) := int(Area.Flags);
      Register.R(5) := int(Max_Size);
      Register.R(6) := 0;
      Register.R(7) := 0;
      Register.R(8) := Adr_To_Int(Name_0'Address);
      Error := Kernel.SWI (OS_DynamicArea, Register'Access, Register'Access);

      if Error /= null then
         pragma Debug(Report("DynamicArea.Create: " & To_Ada(Error.ErrMess)));
         raise unable_to_delete_dynamic_Area;
      end if;

      Area.Area_Nr  := Integer(Register.R(1));
      Area.Max_Size := Integer(Register.R(5));
      Area.Base     := Int_to_adr(Register.R(3));
   end Create;

   --

   procedure Remove(Area : in Dynamic_Area_Type) is

      Register : aliased Kernel.SWI_regs;
      Error    : Kernel.OSError_access;
   begin
      Register.R(0) := 1;
      Register.R(1) := int(Area.Area_Nr);
      Error := Kernel.SWI (OS_DynamicArea, Register'Access, Register'Access);

      if Error /= null then
         pragma Debug(Report("DynamicArea.Remove: " & To_Ada(Error.ErrMess)));
         raise unable_to_delete_dynamic_Area;
      end if;
   end Remove;

   --

   procedure Resize (Area   : in out Dynamic_Area_Type;
                     Change : in Integer) is

      Register    : aliased Kernel.SWI_regs;
      Error       : Kernel.OSError_access;
      Real_Change : Integer := 0;
   begin
      Register.R(0) := int(Area.Area_Nr);
      Register.R(1) := int(Change);
      Error := Kernel.SWI (OS_ChangeDynamicArea, Register'Access, Register'Access);

      Real_Change := Integer(Register.R(1));
      Area.Current_Size := Area.Current_Size + real_change;

      if Error /= null then
         pragma Debug(Report("DynamicArea.Resize: " & To_Ada(Error.ErrMess)));
         raise unable_to_resize_dynamic_Area;
      end if;
   end Resize;

   --

   function Enumerate (Area : in integer) return integer is

      Register : aliased Kernel.SWI_regs;
      Error    : Kernel.osError_access;
   begin
      Register.R(0) := 3;
      Register.R(1) := int(Area);
      Error := Kernel.SWI (OS_DynamicArea, Register'Access, Register'Access);

      if Error /= null then
         pragma Debug(Report("DynamicArea.Enumerate: " & To_Ada(Error.ErrMess)));
         OS.Raise_Error(Error);
       end if;
      return integer(Register.R(1));
   end Enumerate;

   --

   procedure Read (Area_nr      : in  Integer;
                   Base         : out Address;
                   Current_Size : out Integer;
                   Max_size     : out Integer) is

      Register : aliased Kernel.SWI_regs;
      Error    : Kernel.osError_access;
   begin
      Register.R(0) := int(Area_nr);
      Error := Kernel.SWI (OS_ReadDynamicArea, Register'Access, Register'Access);

      if Error /= null then
         pragma Debug(Report("DynamicArea.Read: " & To_Ada(Error.ErrMess)));
         OS.Raise_Error(Error);
       end if;
      Base         := Int_To_Adr(Register.R(0));
      Current_Size := Integer(Register.R(1));
      Max_Size     := Integer(Register.R(2));
   end Read;

   --

   procedure Read_Detailed (Area_nr       : in  Integer;
                            Current_Size  : out Integer;
                            Base          : out Address;
                            Flags         : out Integer;
                            Max_Size      : out Integer;
                            Name          : out Unbounded_String) is

      Register : aliased Kernel.SWI_regs;
      Error    : Kernel.osError_access;
   begin
      Register.R(0) := 2;
      Register.R(1) := int(Area_nr);
      Error := Kernel.SWI (OS_DynamicArea, Register'Access, Register'Access);
      if Error /= null then
         pragma Debug(Report("DynamicArea.Read_Detailed: " & To_Ada(Error.ErrMess)));
         OS.Raise_Error(Error);
      end if;

      Current_Size := Integer(Register.R(2));
      Base         := Int_To_Adr(Register.R(3));
      Flags        := Integer(Register.R(4));
      Max_Size     := Integer(Register.R(5));
      Name := U(MemoryToString(Int_To_Adr(Register.R(8))));
   end Read_Detailed;

   --

   function Exists (Nr : in Integer) return Boolean is

      Area_Read : Integer := Enumerate(-1);
   begin
      while Area_Read /= -1 loop
         if Area_Read = Nr then
            return true;
         end if;
         Area_Read := Enumerate(Area_Read);
      end loop;
      return false;
   end Exists;

   --

   function Exists (Name : in String) return Boolean is

      Area : Integer := Enumerate(-1);
      Len  : Natural := Name'Length;
      Base : Address;
      Name2: Unbounded_String;
      Current_size,Flags,Max_size : Integer;
   begin
      if Len > 31 then
         Len := 31;
      end if;
      while Area /= -1 loop
         Read_Detailed (Area,Current_size,Base,Flags,Max_size,Name2);
         if Name = S(Name2) then
            return true;
         end if;
         Area := Enumerate(Area);
      end loop;
      return false;
   end Exists;

   --

   function Find_Nr (Name : in String) return Integer is

      Area : Integer := Enumerate(-1);
      Len  : Natural := Name'Length;
      Base : Address;
      Name2: Unbounded_String;
      Current_size,Flags,Max_size : integer;
   begin
      if Len > 31 then
         Len := 31;
      end if;
      while Area /= -1 loop
         Read_Detailed (Area,Current_size,Base,Flags,Max_size,Name2);
         if Name = S(Name2) then
            return Area;
         end if;
         Area := Enumerate(Area);
      end loop;
      raise nonexisting_dynamic_area;
   end Find_Nr;

   --

   function Get_Nr_Of_DAs return Natural is

      Area : Integer := Enumerate(-1);
      Nr   : Natural := 0;
   begin
      while Area /= -1 loop
         Nr := Nr + 1;
         Area := Enumerate(Area);
      end loop;
      return Nr;
   end Get_Nr_Of_DAs;

   --

   function Get_DA_List return DA_List_Type is

      Area : Integer := Enumerate (-1);
      Base : Address;
      List : DA_List_Type (1..Get_Nr_Of_DAs);
      Current_size,Flags,Max_size,i : integer;
      Name : Unbounded_String;
      Len  : Natural;
   begin
      i := 1;
      while Area /= -1 loop
         Read_Detailed (Area,Current_size,Base,Flags,Max_size,Name);
         List(i).Area_Nr      := Area;
         List(i).Max_Size     := Max_size;
         List(i).Current_Size := Current_Size;
         List(i).Flags        := Flags;
         List(i).Base         := Base;
         Len := Length(Name);
         if Len > 31 then
            Len := 31;
         end if;
         List(i).Name(1..Len) := Slice(Name,1,Len);
         i := i + 1;
         Area := Enumerate (Area);
      end loop;
      return List;
   end Get_DA_List;

   -------------------
   -- Get functions --
   -------------------

   function Get_Nr (Area : in Dynamic_Area_Type) return integer is

   begin
      return Area.Area_Nr;
   end Get_Nr;

   --

   function Get_Max_Size (Area : in Dynamic_Area_Type) return integer is
   begin
      return Area.Max_Size;
   end Get_Max_Size;

   --

   function Get_Current_Size (Area : in Dynamic_Area_Type) return integer is
   begin
      return Area.Current_Size;
   end Get_Current_Size;

   --

   function Get_Flags (Area : in Dynamic_Area_Type) return integer is
   begin
      return Area.Flags;
   end Get_Flags;

   --

   function Get_Base (Area : in Dynamic_Area_Type) return Address is
   begin
      return Area.Base;
   end Get_Base;

   --

   function Get_Name (Area : in Dynamic_Area_Type) return String is
   begin
      return Area.Name;
   end Get_Name;

   --

end RASCAL.DynamicArea;
