------------------------------------------------------------------------------
--                                                                          --
--                An Ada2005 binding to the Qt C++ framework                --
--                                                                          --
------------------------------------------------------------------------------
--                                                                          --
-- Copyright © 2008-2010 Vadim Godunko <vgodunko@gmail.com>                 --
--                                                                          --
-- QtAda is free software;  you can  redistribute it and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion. QtAda is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License distributed with QtAda;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
------------------------------------------------------------------------------
--  $Revision: 3769 $ $Date: 2010-10-24 03:16:28 +0400 (Sun, 24 Oct 2010) $
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;

package body Qt4_Entities is

   type Entity_Access is access all Entity'Class;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Free_Entity
   --!    <Purpose> Осуществляет уничтожение указанного Ada-объекта. Вызов
   --! подпрограммы осуществляется из класса-директора C++.
   --!    <Exceptions>
   ---------------------------------------------------------------------------
   procedure Free_Entity (Ada_Object : not null access Entity'Class);
   pragma Warnings (Off, Free_Entity);
   pragma Export (C, Free_Entity, "__Qt4Ada_free_Entity");

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Free_Limited_Entity
   --!    <Purpose> Осуществляет уничтожение указанного Ada-объекта. Вызов
   --! подпрограммы осуществляется из класса-директора C++.
   --!    <Exceptions>
   ---------------------------------------------------------------------------
   procedure Free_Limited_Entity
    (Ada_Object : not null access Limited_Entity'Class);
   pragma Warnings (Off, Free_Limited_Entity);
   pragma Export (C, Free_Limited_Entity, "__Qt4Ada_free_LimitedEntity");

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Adjust
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   overriding procedure Adjust (Self : in out Entity) is
   begin
      if not Self.Destroyed
        and then Self.Cpp_Object /= null
      then
         Self.Cpp_Object := Entity'Class (Self).Copy_Cpp_Object;

         --  После копирования новый объект уже требует обязательного "ручного"
         --  удаления, поэтому происходит переключение режима работы сущности
         --  в режим контейнера.

         Self.Role  := Container;
         Self.Class := Static;
      end if;
   end Adjust;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Cpp_Object
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   function Cpp_Object (Self : Entity'Class) return access Cpp_Class is
   begin
      return Self.Cpp_Object;
   end Cpp_Object;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Cpp_Object
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   function Cpp_Object (Self : Limited_Entity'Class) return access Cpp_Class is
   begin
      return Self.Cpp_Object;
   end Cpp_Object;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Default_Cpp_Object
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   function Default_Cpp_Object (Self : not null access Entity)
     return access Cpp_Class
   is
      pragma Unreferenced (Self);
      --  Используется для диспетчеризации надклассового вызова.

   begin
      return null;
   end Default_Cpp_Object;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Default_Cpp_Object
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   function Default_Cpp_Object (Self : not null access Limited_Entity)
     return access Cpp_Class
   is
      pragma Unreferenced (Self);
      --  Используется для диспетчеризации надклассового вызова.

   begin
      return null;
   end Default_Cpp_Object;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Finalize
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   overriding procedure Finalize (Self : in out Entity) is
   begin
      if Self.Role /= Wrapper
        and then not Self.Destroyed
        and then Self.Cpp_Object /= null
      then
         Self.Destroyed := True;
         Entity'Class (Self).Delete_Cpp_Object;
         Self.Cpp_Object := null;
      end if;
   end Finalize;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Finalize
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   overriding procedure Finalize (Self : in out Limited_Entity) is
   begin
      if Self.Role /= Wrapper
        and then not Self.Destroyed
        and then Self.Cpp_Object /= null
      then
         Self.Destroyed := True;
         Limited_Entity'Class (Self).Delete_Cpp_Object;
         Self.Cpp_Object := null;
      end if;
   end Finalize;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Free_Entity
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   procedure Free_Entity (Ada_Object : not null access Entity'Class) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Entity'Class, Entity_Access);

      Aux : Entity_Access := Entity_Access (Ada_Object);

   begin
      if not Ada_Object.Destroyed then
         Ada_Object.Destroyed := True;

         if Ada_Object.Class = Dynamic then
            Free (Aux);
         end if;
      end if;
   end Free_Entity;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Free_Limited_Entity
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   procedure Free_Limited_Entity
    (Ada_Object : not null access Limited_Entity'Class)
   is

      procedure Free is
        new Ada.Unchecked_Deallocation
             (Limited_Entity'Class, Limited_Entity_Access);

      Aux : Limited_Entity_Access := Limited_Entity_Access (Ada_Object);

   begin
      if not Ada_Object.Destroyed then
         Ada_Object.Destroyed := True;

         if Ada_Object.Class = Dynamic then
            Free (Aux);
         end if;
      end if;
   end Free_Limited_Entity;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Initialize
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   overriding procedure Initialize (Self : in out Entity) is
   begin
      Self.Cpp_Object := Entity'Class (Self).Default_Cpp_Object;

      --  Если был создан объект по умолчанию, то сущность переключается в
      --  режим контейнера со статическим размещением. Если это не так, то
      --  создавшая объект подпрограмма должна переключить сущность в
      --  необходимый режим.

      if Self.Cpp_Object /= null then
         Self.Role := Container;
         Self.Class := Static;
      end if;
   end Initialize;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Initialize
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   overriding procedure Initialize (Self : in out Limited_Entity) is
   begin
      Self.Cpp_Object := Limited_Entity'Class (Self).Default_Cpp_Object;

      --  Если был создан объект по умолчанию, то сущность переключается в
      --  режим контейнера со статическим размещением. Если это не так, то
      --  создавшая объект подпрограмма должна переключить сущность в
      --  необходимый режим.

      if Self.Cpp_Object /= null then
         Self.Role := Container;
         Self.Class := Static;
      end if;
   end Initialize;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Is_Director
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   function Is_Director (Self : not null access constant Entity)
     return Boolean
   is
   begin
      return Self.Role = Director;
   end Is_Director;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Is_Director
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   function Is_Director (Self : not null access constant Limited_Entity)
     return Boolean
   is
   begin
      return Self.Role = Director;
   end Is_Director;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Set_Dynamically_Allocated
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   procedure Set_Dynamically_Allocated
    (Self : not null access Entity'Class)
   is
   begin
      Self.Class := Dynamic;
   end Set_Dynamically_Allocated;

   ---------------------------------------------------------------------------
   --! <Subprogram>
   --!    <Unit> Set_Dynamically_Allocated
   --!    <ImplementationNotes>
   ---------------------------------------------------------------------------
   procedure Set_Dynamically_Allocated
    (Self : not null access Limited_Entity'Class)
   is
   begin
      Self.Class := Dynamic;
   end Set_Dynamically_Allocated;

end Qt4_Entities;
