[gtkada] Contribution: using GtkAda from Ada tasks

[Dmitry A. Kazakov]

On Sun, 16 Jul 2006 17:00:40 -0700, you wrote:

> Dmitry A. Kazakov wrote:
> 
>>To whom interest. This package (see attachment) provides a simple
>>synchronization mechanism to use GtkAda with Ada tasks. No locking is used,
>>instead GTK+ requests are executed on the context of the main thread. The
>>package works both under Windows and Linux. It was tested with GtkAda
>>2.4.0.
>>  
> Would it be possible to provide a small example?

with Ada.Exceptions;   use Ada.Exceptions;
with Gdk.Event;        use Gdk.Event;
with Gtk.Main.Router;  use Gtk.Main.Router; 
with Gtk.Window;       use Gtk.Window;
with Gtk.Widget;       use Gtk.Widget;
with Gtk.Table;        use Gtk.Table;
with Gtk.Label;        use Gtk.Label;

with Ada.Unchecked_Conversion;
with Gtk.Handlers;

procedure Test_Gtk is
   --
   -- All data are global, for the sake of  simplicity.  Otherwise,  the
   -- test were impossible to keep in  just  one  body  due  to  Ada  95
   -- restriction on controlled types. 
   --
   Window  : Gtk_Window;
   Grid    : Gtk_Table;
   Label   : Gtk_Label;
   Counter : Integer;
   
   -- Standard GTK stuff
   package Handlers is new Gtk.Handlers.Callback (Gtk_Widget_Record);

   package Return_Handlers is
      new Gtk.Handlers.Return_Callback
          (  Widget_Type => Gtk_Widget_Record,
             Return_Type => Boolean
          );
   function Delete_Event
            (  Widget : access Gtk_Widget_Record'Class;
               Event  : Gdk_Event
            )  return Boolean is
   begin
      return False;
   end Delete_Event;

   -- Destroy  handler  is  standard  for  GTK.   Normally   it   should
   -- communicate with the tasks if the window is closed prematurely.  I
   -- have omitted that stuff. Therefore, if you close  the  application
   -- window, the process will hang. 
   procedure Destroy (Widget : access Gtk_Widget_Record'Class) is
   begin
      Gtk.Main.Main_Quit;
   end Destroy;

   -- Circumvention of access rules, don't do it, it  is  here  only  to
   -- simplify the test 
   type Local_Callback is access procedure;
   function "+" is
      new Ada.Unchecked_Conversion (Local_Callback, Gtk_Callback);
   
   task type Process;

   -- Update will write the label
   procedure Update is
   begin
      Set_Text (Label, "Counter" & Integer'Image (Counter));
   end Update;

   -- The task that calls to Update
   task body Process is
   begin
      for Index in 1..10 loop
         Counter := Index;
         Request (+Update'Access); -- Request execution of Update
         delay 0.5;
      end loop;
   exception
      when Error : others =>
         Say (Exception_Information (Error)); -- This is safe
   end Process;

begin
   Gtk.Main.Init;
   Gtk.Main.Router.Init; -- This must be called once
   Gtk.Window.Gtk_New (Window);
   Set_Title (Window, "Test");
   Return_Handlers.Connect
   (  Window,
      "delete_event",
      Return_Handlers.To_Marshaller (Delete_Event'Access)
   );
   Handlers.Connect
   (  Window,
      "destroy",
      Handlers.To_Marshaller (Destroy'Access)
   );
   Gtk_New (Grid, 1, 1, False);
   Add (Window, Grid);
   Gtk_New (Label, "label");
   Attach (Grid, Label, 0, 1, 0, 1);

   Show (Label);
   Show (Grid);
   Show (Window);
   declare
      Worker : Process; -- Now the task is on
   begin
      --
      -- Enter the events processing loop
      --
      Gtk.Main.Main;
   end;
exception
   when Error : others =>
      Say (Exception_Information (Error)); -- This is safe
end Test_Gtk;