Qt4Ada - An Ada2005 binding to Qt4

 

We'll see here how we can reflect a C++ class hierarchy using Ada tagged types, having virtual C++ methods being dispatched in Ada.

The C++ example

Let's consider the following C++ hierarchy (file): 

  1. // file *** cpp.h ***
  2. struct S
  3. {
  4.    virtual void vm() const;
  5.    void m() const;
  6. };
  7.  
  8. struct T: public S
  9. {
  10.    virtual void vm() const;
  11. };
  12.  

Give these methods some trivial code (file): 

  1. // file *** cpp.cpp ***
  2. #include <iostream>
  3. #include "cpp.h"
  4. void S::vm() const
  5. {
  6.    std::cout << "(Cpp) S::vm\n";
  7. }
  8. void S::m() const
  9. {
  10.    std::cout << "(Cpp) S::m, invoquing vm()...\n";
  11.    vm();
  12. }
  13. void T::vm() const
  14. {
  15.    std::cout << "(Cpp) T::vm\n";
  16. }
  17.  

Note that the m() method calls the virtual method vm(), line 11.

Corresponding Ada package

The previous C++ code is translated into Ada as follow (file):

  1. -- file *** ada_cpp.ads ***
  2. with Ada.Finalization;
  3. package Ada_Cpp is
  4.  
  5.    type Dummy is tagged null record;
  6.    type Cpp_Ptr is access all Dummy'Class;
  7.  
  8.    type Cpp_Access is new Ada.Finalization.Controlled with
  9.    record
  10.       ptr: Cpp_Ptr;
  11.    end record;
  12.  
  13.    type S is new Cpp_Access with null record;
  14.    overriding
  15.    procedure Initialize(obj: in out S);
  16.    not overriding
  17.    procedure vm(obj: in S);
  18.    not overriding
  19.    procedure m(obj: in S'Class);
  20.  
  21.    type T is new S with null record;
  22.    overriding
  23.    procedure Initialize(obj: in out T);
  24.    overriding
  25.    procedure vm(obj: in T);
  26. end Ada_Cpp;
  27.  

So in the Ada package we have the same type hierarchy as in C++: the type T inherits from the type S, both being tagged types having Ada.Finalization.Controlled as base type.

The types Dummy and Cpp_Ptr have the only purpose to have a general access type to a C++ class, which will be seen as a pointer on the C++ side. Maybe the type Interfaces.C.Strings.chars_ptr would be enough for this goal.

Step One: translating C++ to C

The first thing to do now is to translate the C++ code to C code, as well as creating a wrapper for our classes (the reason for this will be explained soon). Here is the wrapper and the C code (file): 

  1. // file *** c.h ***
  2. #include "cpp.h"
  3. struct Ada_S: public S
  4. {
  5.    virtual void vm() const;
  6.    void* _ada;
  7. };
  8. struct Ada_T: public T
  9. {
  10.    virtual void vm() const;
  11.    void* _ada;
  12. };
  13.  
  14. extern "C"
  15. {
  16.    // exported functions
  17.    Ada_S* Create_S(void* ada);
  18.    void S_vm(Ada_S* obj);
  19.    void S_m(Ada_S* obj);
  20.    Ada_T* Create_T(void* ada);
  21.    void T_vm(Ada_T* obj);
  22.  
  23.    // imported functions
  24.    void Dispatch_S_vm(void* ada);
  25.    void Dispatch_T_vm(void* ada);
  26. }
  27.  

Each C++ class is derived into a new class, in which all virtuel method is overdefined. The pointer member void* _ada will be used to gain access to instances created on the Ada side.

Maybe we could have created a common ancestor class containing this pointer and use multiple inheritance, howether strange issues occured when using this technic, so we'll avoid it.

The exported function in the extern "C" block will be implemented on the C++ side and called from Ada, whereas the imported procedure will be implemented on the Ada side and called from C++.

Here's the code corresponding to this header (file): 

  1. // file *** c.cpp ***
  2. #include <iostream>
  3. #include "c.h"
  4.  
  5. void Ada_S::vm() const
  6. {
  7.    std::cout << "(Cpp) Ada_S::vm()\n";
  8.    // perform a dispatching call in Ada
  9.    Dispatch_S_vm(_ada);
  10. }
  11.  
  12. void Ada_T::vm() const
  13. {
  14.    std::cout << "(Cpp) Ada_T::vm()\n";
  15.    // perform a dispatching call in Ada
  16.    Dispatch_T_vm(_ada);
  17. }
  18.  
  19. extern "C"
  20. {
  21.    Ada_S* Create_S(void* ada)
  22.    {
  23.       std::cout << "(C  ) Create_S(void*)\n";
  24.       Ada_S* as = new Ada_S;
  25.       as->_ada = ada;
  26.       return as;
  27.    }
  28.    void S_vm(Ada_S* obj)
  29.    {
  30.       std::cout << "(C  ) S_vm(Ada_S*)\n";
  31.       // calls the ancestor method, the one in
  32.       // the S class
  33.       obj->S::vm();
  34.    }
  35.    void S_m(Ada_S* obj)
  36.    {
  37.       std::cout << "(C  ) S_m(Ada_S*)\n";
  38.       obj->m();
  39.    }
  40.    Ada_T* Create_T(void* ada)
  41.    {
  42.       std::cout << "(C  ) Create_T(void*)\n";
  43.       Ada_T* at = new Ada_T;
  44.       at->_ada = ada;
  45.       return at;
  46.    }
  47.    void T_vm(Ada_T* obj)
  48.    {
  49.       std::cout << "(C  ) T_vm(Ada_T*)\n";
  50.       // calls the ancestor method, the one in
  51.       // the T class
  52.       obj->T::vm();
  53.    }
  54. }
  55.  

First trick, we call ancestor virtual methods in their corresponding C functions, here S_vm() and T_vm(). To put it in other words, calling S_vm() (respectively T_vm()) from Ada will result in a call to S::vm() (respectively T::vm()), not any other method.

On the other hand, calling S_m() from Ada will result in a call to S::m(), which in turn will call the virtual method vm() of the current instance: this last call is thus polymorphic.

Step two: exporting Ada dispatching

Now let's have a look at the package's body (file):

  1. -- file *** ada_cpp.adb ***
  2. with Ada.Text_IO;
  3. use  Ada.Text_IO;
  4.  
  5. package body Ada_Cpp is
  6.  
  7.    -- first of all, we import C functions which we'll use
  8.    -- to gain access to C++ code:
  9.  
  10.    function Create_S(obj: in S)
  11.       return Cpp_Ptr;
  12.    pragma Import(C, Create_S, "Create_S");
  13.  
  14.    procedure S_vm(ptr: in Cpp_Ptr);
  15.    pragma Import(C, S_vm, "S_vm");
  16.  
  17.    procedure S_m(ptr: in Cpp_Ptr);
  18.    pragma Import(C, S_m, "S_m");
  19.  
  20.    function Create_T(obj: in T)
  21.       return Cpp_Ptr;
  22.    pragma Import(C, Create_T, "Create_T");
  23.  
  24.    procedure T_vm(ptr: in Cpp_Ptr);
  25.    pragma Import(C, T_vm, "T_vm");
  26.  
  27.    -- now giving types' operations' bodies
  28.  
  29.    overriding
  30.    procedure Initialize(obj: in out S) is
  31.       -- creating an instance of Ada_S on C++ side
  32.       cpp_s: constant Cpp_Ptr := Create_S(obj);
  33.    begin
  34.       Put_Line("(Ada) Initialize(S)");
  35.       obj.ptr := cpp_s;
  36.    end Initialize;
  37.  
  38.    not overriding
  39.    procedure vm(obj: in S) is
  40.    begin
  41.       Put_Line("(Ada) vm(S)");
  42.       S_vm(obj.ptr);
  43.    end vm;
  44.  
  45.    not overriding
  46.    procedure m(obj: in S'Class) is
  47.    begin
  48.       Put_Line("(Ada) m(S'Class)");
  49.       S_m(obj.ptr);
  50.    end m;
  51.  
  52.    -- exporting the dispatching procedure
  53.    procedure Dispatch_S_vm(obj: in S'Class);
  54.    pragma Export(C, Dispatch_S_vm, "Dispatch_S_vm");
  55.  
  56.    procedure Dispatch_S_vm(obj: in S'Class) is
  57.    begin
  58.       Put_Line("(Ada) Dispatch_S_vm(S'Class)");
  59.       -- the following call is dispatching
  60.       vm(obj);
  61.    end Dispatch_S_vm;
  62.  
  63.    --
  64.  
  65.    overriding
  66.    procedure Initialize(obj: in out T) is
  67.       cpp_t: constant Cpp_Ptr := Create_T(obj);
  68.    begin
  69.       Put_Line("(Ada) Initialize(T)");
  70.       obj.ptr := cpp_t;
  71.    end Initialize;
  72.  
  73.    overriding
  74.    procedure vm(obj: in T) is
  75.    begin
  76.       Put_Line("(Ada) vm(T)");
  77.       T_vm(obj.ptr);
  78.    end vm;
  79.  
  80.    -- exporting the dispatching procedure
  81.    procedure Dispatch_T_vm(obj: in T'Class);
  82.    pragma Export(C, Dispatch_T_vm, "Dispatch_T_vm");
  83.  
  84.    procedure Dispatch_T_vm(obj: in T'Class) is
  85.    begin
  86.       Put_Line("(Ada) Dispatch_T_vm(T'Class)");
  87.       -- the following call is dispatching
  88.       vm(obj);
  89.    end Dispatch_T_vm;
  90.  
  91. end Ada_Cpp;
  92.  

As you've already guessed, the trick resides in the Dispatch_* procedures. Note that they're not even declared in the package's specification: they shall only be called from the "wrapper" C++ code.

Both Dispatch_S_vm() and Dispatch_T_vm take a 'Class parameter, and both call a primitive operation of the type: we actually have dispatching. Thus, if the primitive operation (here, vm()) is overriden, then the overriding one will be called, even from within C++, because we have overdefined the virtual method and we're using a subclass, not directly the class itself.

Deriving C++ types in Ada

To make sure all of this works, let's create two new Ada types (file):

  1. -- file *** ders.ads ***
  2. with Ada_Cpp;
  3. package Ders is
  4.  
  5.    type Der_1 is new Ada_Cpp.S with null record;
  6.    overriding
  7.    procedure vm(obj: in Der_1);
  8.  
  9.    type Der_2 is new Ada_Cpp.T with null record;
  10.    overriding
  11.    procedure vm(obj: in Der_2);
  12.  
  13. end Ders;
  14.  

And the body, pure Ada (file):

  1. -- file *** ders.adb ***
  2. with Ada.Text_IO;
  3. use  Ada.Text_IO;
  4. package body Ders is
  5.  
  6.    overriding
  7.    procedure vm(obj: in Der_1) is
  8.    begin
  9.       Put_Line("(Ada) vm(Der_1)");
  10.    end vm;
  11.  
  12.    overriding
  13.    procedure vm(obj: in Der_2) is
  14.    begin
  15.       Put_Line("(Ada) vm(Der_2)");
  16.    end vm;
  17.  
  18. end Ders;
  19.  

And at last, a small test program (file):

  1. -- file *** test.adb ***
  2. with Ada.Text_IO;
  3. use  Ada.Text_IO;
  4. with Ada_Cpp;
  5. with Ders;
  6.  
  7. procedure Test is
  8.  
  9.    s: Ada_Cpp.S;
  10.    t: Ada_Cpp.T;
  11.    d1: Ders.Der_1;
  12.    d2: Ders.Der_2;
  13.  
  14. begin
  15.  
  16.    Put_Line("--- START ---");
  17.    s.m;
  18.    Put_Line("--");
  19.    t.m;
  20.    Put_Line("--");
  21.    d1.m;
  22.    Put_Line("--");
  23.    d2.m;
  24.    Put_Line("--- END ---");
  25.  
  26. end Test;
  27.  

You can use the following commands to compile (GCC 4.1.1):

  1. $ g++ -c c.cpp cpp.cpp
  2. $ gnatmake -gnat05 test -largs c.o cpp.o -lstdc++

And here's the result:

  1. (C  ) Create_S(void*)
  2. (Ada) Initialize(S)
  3. (C  ) Create_T(void*)
  4. (Ada) Initialize(T)
  5. (C  ) Create_S(void*)
  6. (Ada) Initialize(S)
  7. (C  ) Create_T(void*)
  8. (Ada) Initialize(T)
  9. --- START ---

Simply the various initializations.

 
  1. (Ada) m(S'Class)
  2. (C  ) S_m(Ada_S*)
  3. (Cpp) S::m, invoquing vm()...
  4. (Cpp) Ada_S::vm()
  5. (Ada) Dispatch_S_vm(S'Class)
  6. (Ada) vm(S)
  7. (C  ) S_vm(Ada_S*)
  8. (Cpp) S::vm
  9. --

The first call to the m() method (from an instance of S), which in turn calls the virtual method vm().

The call path is pictured below (green for Ada, yellow for C, blue for C++), the virtual/dispatching calls being drawn as red arrows:/p> 

  1. (Ada) m(S'Class)
  2. (C  ) S_m(Ada_S*)
  3. (Cpp) S::m, invoquing vm()...
  4. (Cpp) Ada_T::vm()
  5. (Ada) Dispatch_T_vm(T'Class)
  6. (Ada) vm(T)
  7. (C  ) T_vm(Ada_T*)
  8. (Cpp) T::vm
  9. --

Now m() is called from an instance of T.

 
  1. (Ada) m(S'Class)
  2. (C  ) S_m(Ada_S*)
  3. (Cpp) S::m, invoquing vm()...
  4. (Cpp) Ada_S::vm()
  5. (Ada) Dispatch_S_vm(S'Class)
  6. (Ada) vf(Der_1)
  7. --

Calling m() from an instance of our pure-Ada type Der_1. The dispatching occures as expected, it's the overriden procedure which is called.

 
  1. (Ada) m(S'Class)
  2. (C  ) S_m(Ada_S*)
  3. (Cpp) S::m, invoquing vm()...
  4. (Cpp) Ada_S::vm()
  5. (Ada) Dispatch_S_vm(S'Class)
  6. (Ada) vf(Der_2)
  7. --

Just for the sake of completeness, calling m() from an instance of our pure-Ada type Der_2.