Issue with GNAT GPL 2009 and GtkAda

[Damien Carbonne <damien.carbonne@free.fr>]

Hi,

When compiling a program I had written to GNAT GPL 2009 on Linux and 
Windows, I met a problem with the usage of Gtk.Tree_Model.Foreach.

I wrote a relatively small program (unfortunately, still quite long) 
that reproduces the problem (attached in the end).

I wonder if this is a bug in
    1) my program,
    2) GtkAda or
    3) GNAT GPL 2009.
What surprises me is that it was quite hard to reproduce this problem.
Most other examples I wrote with Foreach worked very well.
I don't know how GNAT handles accessibility rules.
I wonder if the problem is not related to the usage of Interfaces ?
I did not try yet to change the program so that it can work, but other 
examples I wrote were quite similar, except that they did not use 
interfaces. I'll check, but do you have any idea on this issue ?

Thanks for help !

Regards,

Damien Carbonne


--------------------------------------------------------------------------
with Bug;
procedure Main is
begin
    Bug.Main;
end Main;
-- Tested with GNAT GPL 2009 on Linux

-- When this program is run, these messages are printed:
--
-- View.Window.Gtk_New
-- View.Window.Initialize
-- View.Store.Gtk_New
-- View.Store.Initialize
-- Model.Attach_Listener
--
-- Then, when one clicks in "Click here to raise exception" button,
-- those one are printed:
--
-- View.Window.On_Reset_Usage_Clicked
-- Model.Do_Something_And_Notify_Listener
-- View.Store.Process
-- View.Store.Visit_Nodes
-- View.Store.Run Foreach ...
-- Exception raised in View.Store.Visit_Nodes
-- Exception name: PROGRAM_ERROR
-- Message: gtk-tree_model.adb:838 accessibility check failed
--
--
-- raised PROGRAM_ERROR : gtk-tree_model.adb:838 accessibility check failed

--------------------------------------------------------------------------
with Gtk.Tree_Store;      use Gtk.Tree_Store;
with Gtk.Window;          use Gtk.Window;
with Gtk.Box;             use Gtk.Box;
with Gtk.Button;          use Gtk.Button;
with Gtk.Tree_View;       use Gtk.Tree_View;

package Bug is

 
-----------------------------------------------------------------------------
    -- This package is a simplified model representation
    -- It holds an access to 1 listener and calls the attached listener
    -- when Do_Something_And_Notify_Listeneris called
    package Model is

       procedure Do_Something_And_Notify_Listener;

       type Model_Listener is limited interface;
       type Model_Listener_Ref is access all Model_Listener'Class;
       procedure Process (Listener : in out Model_Listener) is abstract;

       procedure Attach_Listener (Listener : Model_Listener_Ref);

    end Model;
 
-----------------------------------------------------------------------------
    -- This package is a simplified view representation
    package View is
 
--------------------------------------------------------------------------
       -- This package is supposed to contain a tree representation of
       -- the above model.
       -- The store is also a listener of the above model.
       -- When process is called, Foreach is called, and the program
       -- terminates with an exception.
       package Store is
          Index_Name : constant := 0;
          -- Index used to store a string (name)

          type View_Store_Record is new Gtk_Tree_Store_Record and
            Model.Model_Listener with private;

          type View_Store is access all View_Store_Record'Class;

          procedure Gtk_New (Store : out View_Store);
          procedure Initialize (Store : access View_Store_Record'Class);

       private
          type View_Store_Record is new Gtk_Tree_Store_Record and
            Model.Model_Listener with null record;
          overriding
          procedure Process (Store : in out View_Store_Record);
       end Store;
 
--------------------------------------------------------------------------
       -- This package is supposed to provide the graphical
       -- representation of the above tree store.
       -- When the user click on the button, a call to
       -- Model.Do_Something_And_Notify_Listener is done.
       -- The attached model listener is then called.
       package Window is
          type View_Window_Record is new Gtk_Window_Record with record
             Vbox      : Gtk_Vbox;
             Button    : Gtk_Button;
             Tree_View : Gtk_Tree_View;
          end record;

          type View_Window_Ref is access all View_Window_Record'Class;

          procedure Gtk_New (Widget : out View_Window_Ref);
          procedure Initialize
            (Widget : access View_Window_Record'Class);
       end Window;
 
--------------------------------------------------------------------------
    end View;
 
-----------------------------------------------------------------------------
    procedure Main;
end Bug;

with System;
with Ada.Text_IO;
with Ada.Exceptions;
with Gtk.Tree_Model;         use Gtk.Tree_Model;
with Glib;
with Gtk.Enums;              use Gtk.Enums;
with Gtk.Tree_View_Column;   use Gtk.Tree_View_Column;
with Gtk.Cell_Renderer_Text; use Gtk.Cell_Renderer_Text;
with Gtk.Widget;             use Gtk.Widget;
with Gtk.Handlers;
with Gtk.Main;

package body Bug is

    -----------
    -- Model --
    -----------

    package body Model is

       G_Listener : Model_Listener_Ref := null;

       --------------------------------------
       -- Do_Something_And_Notify_Listener --
       --------------------------------------

       procedure Do_Something_And_Notify_Listener is
       begin
          Ada.Text_IO.Put_Line
            ("Model.Do_Something_And_Notify_Listener");
          if G_Listener /= null then
             G_Listener.Process;
          end if;
       end Do_Something_And_Notify_Listener;

       ---------------------
       -- Attach_Listener --
       ---------------------

       procedure Attach_Listener (Listener : Model_Listener_Ref) is
       begin
          Ada.Text_IO.Put_Line ("Model.Attach_Listener");
          G_Listener := Listener;
       end Attach_Listener;

    end Model;

    ----------
    -- View --
    ----------

    package body View is

       -----------
       -- Store --
       -----------

       package body Store is

          ----------------
          -- Visit_Node --
          ----------------

          function Visit_Node
            (Model     : access Gtk_Tree_Model_Record'Class;
             Path      : Gtk_Tree_Path;
             Iter      : Gtk_Tree_Iter;
             User_Data : System.Address)
             return      Boolean
          is
             pragma Unreferenced (Model, Iter, User_Data);
          begin
             Ada.Text_IO.Put_Line
               ("View.Store.Visit_Node: [" & To_String (Path) & "]");
             return False;
          end Visit_Node;

          -----------------
          -- Visit_Nodes --
          -----------------

          procedure Visit_Nodes
            (Store : access View_Store_Record'Class)
          is
          begin
             Ada.Text_IO.Put_Line ("View.Store.Visit_Nodes");
             Ada.Text_IO.Put_Line ("View.Store.Run Foreach ...");
             Foreach (Store, Visit_Node'Access, System.Null_Address);
             Ada.Text_IO.Put_Line ("View.Store.Foreach Done");
          exception
             when E : others =>
                Ada.Text_IO.Put_Line
                  ("Exception raised in View.Store.Visit_Nodes");
                Ada.Text_IO.Put_Line
                  (Ada.Exceptions.Exception_Information (E));
                raise;
          end Visit_Nodes;

          -------------
          -- Gtk_New --
          -------------

          procedure Gtk_New (Store : out View_Store) is
          begin
             Ada.Text_IO.Put_Line ("View.Store.Gtk_New");
             Store := new View_Store_Record;
             Initialize (Store);
          end Gtk_New;

          ----------------
          -- Initialize --
          ----------------

          procedure Initialize
            (Store : access View_Store_Record'Class)
          is
             Iter : Gtk_Tree_Iter;
          begin
             Ada.Text_IO.Put_Line ("View.Store.Initialize");
             Gtk.Tree_Store.Initialize
               (Store,
                Glib.GType_Array'(Index_Name => Glib.GType_String));

             -- Create dummy nodes in the store
             Store.Insert (Iter, Null_Iter, 0);
             Store.Set (Iter, Index_Name, "Root");

             -- Attach itself as a listener
             Model.Attach_Listener (Model.Model_Listener_Ref (Store));
          end Initialize;

          -------------
          -- Process --
          -------------

          procedure Process (Store : in out View_Store_Record) is
          begin
             Ada.Text_IO.Put_Line ("View.Store.Process");
             Store.Visit_Nodes;
          end Process;

       end Store;

       ------------
       -- Window --
       ------------

       package body Window is
          package Button_Cb is new
             Gtk.Handlers.Callback (Gtk_Button_Record);
          G_View_Store : Store.View_Store := null;

          ----------------------------
          -- On_Reset_Usage_Clicked --
          ----------------------------

          procedure On_Reset_Usage_Clicked
            (Widget : access Gtk_Button_Record'Class)
          is
             pragma Unreferenced (Widget);
          begin
             Ada.Text_IO.Put_Line ("View.Window.On_Reset_Usage_Clicked");
             Model.Do_Something_And_Notify_Listener;
          end On_Reset_Usage_Clicked;

          -------------
          -- Gtk_New --
          -------------

          procedure Gtk_New (Widget : out View_Window_Ref) is
          begin
             Ada.Text_IO.Put_Line ("View.Window.Gtk_New");
             Widget := new View_Window_Record;
             Initialize (Widget);
          end Gtk_New;

          ----------------
          -- Initialize --
          ----------------

          procedure Initialize
            (Widget : access View_Window_Record'Class)
          is
             Column        : Gtk_Tree_View_Column;
             Text_Renderer : Gtk_Cell_Renderer_Text;
             Foo           : Glib.Gint;
             pragma Unreferenced (Foo);
             use Store;
          begin
             Ada.Text_IO.Put_Line ("View.Window.Initialize");

             -- Window
             Gtk.Window.Initialize (Widget, Window_Toplevel);
             Set_Title (Widget, "Bug with Foreach");
             Set_Default_Size (Widget, 300, 200);

             -- VBox
             Gtk_New_Vbox (Widget.Vbox, False, 0);
             Add (Widget, Widget.Vbox);

             -- Button
             Gtk_New (Widget.Button, "Click here to raise exception");
             Pack_Start
               (Widget.Vbox,
                Widget.Button,
                Expand  => False,
                Fill    => False,
                Padding => 0);

             -- Tree view
             Gtk_New (Widget.Tree_View);
             Set_Headers_Visible (Widget.Tree_View, True);
             Pack_Start
               (Widget.Vbox,
                Widget.Tree_View,
                Expand  => True,
                Fill    => True,
                Padding => 0);

             -- Renderers
             Gtk_New (Column);
             Set_Title (Column, "Title");
             Foo := Append_Column (Widget.Tree_View, Column);

             Gtk_New (Text_Renderer);
             Pack_Start (Column, Text_Renderer, False);
             Add_Attribute (Column, Text_Renderer, "text",
                            Store.Index_Name);

             -- Callbacks
             Button_Cb.Connect
               (Widget.Button,
                "clicked",
                Button_Cb.To_Marshaller (On_Reset_Usage_Clicked'Access));

             -- Create once the same log store shared by all windows
             if G_View_Store = null then
                Gtk_New (G_View_Store);
             end if;

             Set_Model (Widget.Tree_View, G_View_Store.all'Access);
          end Initialize;

       end Window;

    end View;

    ----------
    -- Main --
    ----------

    procedure Main is
       G_Window : View.Window.View_Window_Ref := null;
    begin
       Gtk.Main.Set_Locale;
       Gtk.Main.Init;
       View.Window.Gtk_New (G_Window);
       G_Window.Show_All;
       Gtk.Main.Main;
    end Main;

end Bug;