---------------------------------------------------------------
--                                                           
--  MCC-GTK_SIGNALS.ADB 
--  Description : Binding to Gtk Signals for RAPID 
--                       
--  By: Martin Carlisle
--  This is a derivative work.  See below
------------------------------------------------------------------------
--          GtkAda - Ada95 binding for the Gimp Toolkit              --
--                                                                   --
--                     Copyright (C) 1998-1999                       --
--        Emmanuel Briot, Joel Brobecker and Arnaud Charlet          --
--                                                                   --
-- This library is free software; you can redistribute it and/or     --
-- modify it under the terms of the GNU General Public               --
-- License as published by the Free Software Foundation; either      --
-- version 2 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 --
-- General Public License for more details.                          --
--                                                                   --
-- You should have received a copy of the GNU 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.                                       --
--                                                                   --
-- 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.     --
-----------------------------------------------------------------------
with System;
with Ada.Unchecked_Conversion;
with Gdk;
with Glib; 
use Glib;
with Unchecked_Deallocation;
package body Mcc.Gtk_Signals is

   type DestroyFunc is access procedure (Data : in System.Address);
   type GtkArgArray is new System.Address;
   type MarshallerFunc is access procedure (Object    : in System.Address;
                                            User_Data : in System.Address;
                                            Nparams   : in Guint;
                                            Params    : in GtkArgArray);
   function Do_Signal_Connect (Object     : in Gtk.Object.Gtk_Object;
                               Name       : in String;
                               Marshaller : in System.Address;
                               Func_Data  : in System.Address;
                               Destroy    : in System.Address;
                               After      : in Boolean)
                               return          Guint;

   -----------------------
   -- Do_Signal_Connect --
   -----------------------

   function Do_Signal_Connect (Object     : in Gtk.Object.Gtk_Object;
                               Name       : in String;
                               Marshaller : in System.Address;
                               Func_Data  : in System.Address;
                               Destroy    : in System.Address;
                               After      : in Boolean)
                               return         Guint
   is
      function Internal (Object        : System.Address;
                         Name          : String;
                         Func          : System.Address;
                         Marshaller    : System.Address;
                         Func_Data     : System.Address;
                         Destroy       : System.Address;
                         Object_Signal : Gint;
                         After         : Gint)
                         return          Guint;
      pragma Import (C, Internal, "gtk_signal_connect_full");
   begin
      return Internal (Gdk.Get_Object (Object.all),
                       Name & Ascii.NUL,
                       System.Null_Address,
                       Marshaller,
                       Func_Data,
                       Destroy,
                       Boolean'Pos (False),
                       Boolean'Pos (After));
   end Do_Signal_Connect;

   ----------------------------
   -- Object_Callback_Return --
   ----------------------------

   package body Object_Callback_Return is
      type Widget_Type is access all Base_Type;
      type Data_Type_Record is
         record
            Func : Callback;
            Data : Widget_Type;
         end record;
      type Data_Type_Access is access Data_Type_Record;

      pragma Convention (C, Data_Type_Access);

      function Convert is new Ada.Unchecked_Conversion (Data_Type_Access,
                                                    System.Address);
      function Convert is new Ada.Unchecked_Conversion (System.Address,
                                                    Data_Type_Access);

      procedure Free_Data (Data : in System.Address);
      pragma Convention (C, Free_Data);

      function Marshaller (Object    : in System.Address;
                            User_Data : in System.Address;
                            Nparams   : in Guint;
                            Params    : in GtkArgArray) return Return_Value;
      pragma Convention (C, Marshaller);

      ---------------
      -- Free_Data --
      ---------------

      procedure Free_Data (Data : in System.Address) is
         procedure Internal is new Unchecked_Deallocation
           (Data_Type_Record, Data_Type_Access);
         D : Data_Type_Access := Convert (Data);
      begin
         Internal (D);
      end Free_Data;

      ----------------
      -- Marshaller --
      ----------------

      function Marshaller (Object    : in System.Address;
                            User_Data : in System.Address;
                            Nparams   : in Guint;
                            Params    : in GtkArgArray) return Return_Value
      is
         Data : Data_Type_Access := Convert (User_Data);
         Dummy : Return_Value;
      begin
         if Data.Func /= null then
            return Data.Func (Data.Data);
         end if;
         return Dummy;
      end Marshaller;

      -------------
      -- Connect --
      -------------

      function Connect
        (Obj         : access Gtk.Object.Gtk_Object_Record'Class;
         Name        : in String;
         Func        : in Callback;
         Slot_Object : access Base_Type'Class;
         After       : in Boolean := False)
         return Guint
      is
         D : Data_Type_Access
           := new Data_Type_Record'(Data => Widget_Type (Slot_Object),
                                    Func => Func);
      begin
         return Do_Signal_Connect (Gtk.Object.Gtk_Object (Obj),
                                   Name,
                                   Marshaller'Address,
                                   Convert (D),
                                   Free_Data'Address,
                                   After);
      end Connect;
   end Object_Callback_Return;

   --------------------------
   -- Object_Callback_Void --
   --------------------------

   package body Object_Callback_Void is
      type Widget_Type is access all Base_Type;
      type Data_Type_Record is
         record
            Func : Callback;
            Data : Widget_Type;
         end record;
      type Data_Type_Access is access Data_Type_Record;

      pragma Convention (C, Data_Type_Access);

      function Convert is new Ada.Unchecked_Conversion (Data_Type_Access,
                                                    System.Address);
      function Convert is new Ada.Unchecked_Conversion (System.Address,
                                                    Data_Type_Access);

      procedure Free_Data (Data : in System.Address);
      pragma Convention (C, Free_Data);

      procedure Marshaller (Object    : in System.Address;
                            User_Data : in System.Address;
                            Nparams   : in Guint;
                            Params    : in GtkArgArray);
      pragma Convention (C, Marshaller);

      ---------------
      -- Free_Data --
      ---------------

      procedure Free_Data (Data : in System.Address) is
         procedure Internal is new Unchecked_Deallocation
           (Data_Type_Record, Data_Type_Access);
         D : Data_Type_Access := Convert (Data);
      begin
         Internal (D);
      end Free_Data;

      ----------------
      -- Marshaller --
      ----------------

      procedure Marshaller (Object    : in System.Address;
                            User_Data : in System.Address;
                            Nparams   : in Guint;
                            Params    : in GtkArgArray)
      is
         Data : Data_Type_Access := Convert (User_Data);
      begin
         if Data.Func /= null then
            Data.Func (Data.Data);
         end if;
      end Marshaller;

      -------------
      -- Connect --
      -------------

      function Connect
        (Obj         : access Gtk.Object.Gtk_Object_Record'Class;
         Name        : in String;
         Func        : in Callback;
         Slot_Object : access Base_Type'Class;
         After       : in Boolean := False)
         return Guint
      is
         D : Data_Type_Access
           := new Data_Type_Record'(Data => Widget_Type (Slot_Object),
                                    Func => Func);
      begin
         return Do_Signal_Connect (Gtk.Object.Gtk_Object (Obj),
                                   Name,
                                   Marshaller'Address,
                                   Convert (D),
                                   Free_Data'Address,
                                   After);
      end Connect;
   end Object_Callback_Void;

end Mcc.Gtk_Signals;

