C++/Ada dispatching

[Tarek Ghaleb <invalid@invalid.org>]

Hi everyone,

Here is the problem: given a C++ class Fl_Widget and a derived class
Fl_Window, I'd like to write a thick binding that wraps the C++ type
into an Ada Type and offers only a subset of the available operations,
plus do type conversions, etc. before calling the C++ operations. So
the basic idea is that an Ada Widget is in the form of,

   type Fl_Widget is abstract tagged limited record
      Base_Widget : access Class_Fl_Widget.Fl_Widget'Class;
   end record;

And here is an example: 

(Apologies for including so much code, I tried to strip it down as
much as possible but still give a complete example).

header file fl_widget.hpp:

  class Fl_Widget {
    int _width;
    int _height;
  public:
    void show();
    virtual void some_operation() { };
  protected:
    Fl_Widget();
    Fl_Widget(int width, int height);
  };

header file fl_window.hpp:

  #include "fl_widget.hpp"

  class Fl_Window : public Fl_Widget {
  public:
    Fl_Window();
    Fl_Window(int width, int height);
    void fullscreen();
    void some_operation();
  };

C++ file fl_widget.cpp:

  #include "fl_widget.hpp"
  #include <cstdio>

  Fl_Widget::Fl_Widget() {}

  Fl_Widget::Fl_Widget(int width, int height) {
    _width  = width;
    _height = height;
  }

  void Fl_Widget::show() {
    std::puts("view called");
  }

C++ file fl_window.cpp:

  #include "fl_window.hpp"
  #include <cstdio>

  Fl_Window::Fl_Window() {}

  Fl_Window::Fl_Window(int width, int height) : Fl_Widget(width, height)
  {
    std::puts("initialized window");
  }

  void Fl_Window::fullscreen() {
    std::puts("fullscreen called");
  }

  void Fl_Window::some_operation() {
    // empty
  }

generated Ada thin binding fl_widget_hpp.ads:

  pragma Ada_2005;
  pragma Style_Checks (Off);

  with Interfaces.C; use Interfaces.C;

  package fl_widget_hpp is

     package Class_Fl_Widget is
	type Fl_Widget is tagged limited record
	   u_width  : aliased int;
	   u_height : aliased int;
	end record;
	pragma Import (CPP, Fl_Widget);

	procedure show (this : access Fl_Widget'Class);  
	pragma Import (CPP, show, "_ZN9Fl_Widget4showEv");

	procedure some_operation (this : access Fl_Widget);
	pragma Import 
          (CPP, some_operation, "_ZN9Fl_Widget14some_operationEv");

	function New_Fl_Widget return Fl_Widget;
	pragma CPP_Constructor (New_Fl_Widget, "_ZN9Fl_WidgetC1Ev");

	function New_Fl_Widget 
	   (width : int; height : int) return Fl_Widget;
	pragma CPP_Constructor (New_Fl_Widget, "_ZN9Fl_WidgetC1Eii");


     end;
     use Class_Fl_Widget;
  end fl_widget_hpp;

generated Ada thin binding fl_window_hpp.ads:

  pragma Ada_2005;
  pragma Style_Checks (Off);

  with Interfaces.C; use Interfaces.C;
  with fl_widget_hpp;

  package fl_window_hpp is

     package Class_Fl_Window is
	type Fl_Window is limited new
	fl_widget_hpp.Class_Fl_Widget.Fl_Widget with record
	   null;
	end record;
	pragma Import (CPP, Fl_Window);

	function New_Fl_Window return Fl_Window;
	pragma CPP_Constructor (New_Fl_Window, "_ZN9Fl_WindowC1Ev");

	function New_Fl_Window 
	  (width : int; height : int) return Fl_Window;
	pragma CPP_Constructor (New_Fl_Window, "_ZN9Fl_WindowC1Eii");

	procedure fullscreen (this : access Fl_Window'Class);
	pragma Import (CPP, fullscreen, "_ZN9Fl_Window10fullscreenEv");

	procedure some_operation (this : access Fl_Window);
	pragma Import 
          (CPP, some_operation, "_ZN9Fl_Window14some_operationEv");
     end;
     use Class_Fl_Window;
  end fl_window_hpp;

and the Ada file widget.ads:

  with fl_widget_hpp;

  package Widget is

     type Fl_Widget is abstract tagged limited record
	Base_Widget : access 
          fl_widget_hpp.Class_Fl_Widget.Fl_Widget'Class;
     end record;

     procedure Show (Object : Fl_Widget);

  end Widget;

with body in widget.adb:

  package body Widget is

     procedure Show (Object : Fl_Widget) is
     begin
	Object.Base_Widget.show;
     end Show;

  end Widget;

and window.ads:

with Widget;

package Window is

   type Fl_Window is new Widget.Fl_Widget with null record;

   procedure Init (Object : in out Fl_Window);

   procedure Fullscreen (Object : Fl_Window);

end Window;

and body in window.adb:

  with fl_window_hpp; use fl_window_hpp;

  package body Window is

     type Base_Window_Access is access all Class_Fl_Window.Fl_Window;

     procedure Init (Object : in out Fl_Window) is
	Win : constant Base_Window_Access :=
	  new Class_Fl_Window.Fl_Window'(
					 Class_Fl_Window.New_Fl_Window
					   (width  => 500,
					    height => 500));
	--  Is there a better way to do this?
     begin
	Object.Base_Widget := Win;
     end Init;

     procedure Fullscreen (Object : Fl_Window) is
     begin
	Base_Window_Access (Object.Base_Widget).fullscreen;
	--  This fails with
	--  raised CONSTRAINT_ERROR : window.adb:36 tag check failed
     end Fullscreen;

  end Window;

and finally a driver to test this code:

  with Window;

  procedure Main is
     Win : Window.Fl_Window;
  begin
     Win.Init;
     --  Curiously, commenting this line out, no errors are raised and
     --  fullscreen() is called. (Although, Base_Widget is
     --  uninitialized/null here!)

     Win.Show;
     Win.Fullscreen;
  end Main;


I'm getting raised CONSTRAINT_ERROR : window.adb:36 tag check failed,
the line

	Base_Window_Access (Object.Base_Widget).fullscreen;

Also, I'm looking for related reading material. So far I've only found
a couple of GEM's on AdaCore and a section in the GNAT manual, and a
Green Hills `Mixing Ada and C++' report. Any recommendations?

Another question: when importing overloaded C++ functions, the
generated code with `g++ -fdump-ada-spec` fails to compile as it
imports the function twice, for example:

     function align 
       (this : access constant Fl_Widget'Class) 
        return FL_Enumerations_H.Fl_Align;
      pragma Import (CPP, align, "_ZNK9Fl_Widget5alignEv");

      procedure align 
        (this : access Fl_Widget'Class; 
         alignment : FL_Enumerations_H.Fl_Align);
      pragma Import (CPP, align, "_ZN9Fl_Widget5alignEj");

how should overloaded C++ functions be imported?

Tarek. 

-- 
Injustice anywhere is a threat to justice everywhere. -- Martin Luther
King, Jr.

--- news://freenews.netfront.net/ - complaints: news@netfront.net ---