Code-a-holic: [Ada (GNAT)] Who said, "Ignorance is bliss"?

Thursday, December 13, 2007

[Ada (GNAT)] Who said, "Ignorance is bliss"?

Ignorance isn't bliss. For the past two days I've been trying to do what I expect an Ada freak could do in 2 minutes. It's been a very frustrating, sleep-depriving process.

After trying to do amazing things with GNAT.Spitbol, I'm now trying to do the same to Dr. Dmitry A. Kazakov's match library. And, as usual, it has not been an easy journey.

UTF-32 aside for now, I've been trying this week simply to make the Matching and Pattern packages available to the Windows programmer via the DLL mechanism.

At this point, all I have is a wrapper for the match() function.

I really hope there is an easier way of doing this. As I've said a few times before, I'm a newbie when it comes to Ada but have been forced to jump into the deep end of the pool. Please, if you know a better way, tell me!!

Oh, and I should point out that, though it seems I'm passing the right stuff to match(), in its current form the VB6 code keeps receiving an error code from the Matching package. It may be because I'm not declaring the pattern properly.

Okay, to the code. First up, the BOS.ADS spec file:

--bos.ads
with GNAT.Spitbol; use GNAT.Spitbol;
with Interfaces.C; use Interfaces.C;
with Interfaces.C.Strings; use Interfaces.C.Strings;
with Win32; use Win32;

package BOS is
   procedure Initialize_API;
   procedure Finalize_API;

   function pmatch( pLength : Win32.LONG; 
                    pString : Win32.LONG; 
                    pPointer : Win32.LONG; 
                    pPattern : Win32.LONG ) 
            return Win32.LONG;
   
private
   pragma Export (DLL, Initialize_API );
   pragma Export (DLL, Finalize_API  );
   pragma Export (DLL, pmatch );
end BOS;

Next, the body (BOS.ADB). There are lots of Put calls in here for debugging. These are what appear if you run the VB6 code as a console app.

-- BOS.ADB
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Strings.Bounded;
use Ada.Strings.Bounded;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Integer_Text_IO;
use Ada.Integer_Text_IO;
with Interfaces.C; use Interfaces.C;
with Interfaces.C.Strings; use Interfaces.C.Strings;
with System;
with Unchecked_Conversion;
with Win32; use Win32;
with Win32.Winbase; use Win32.Winbase;

with Matching; use Matching;
with Patterns; use PAtterns;

package body BOS is

    type VBLong is
        record
            L : Win32.LONG;
        end record;

    type PointerToVBLong is access VBLong;
    type Access_Int is access Interfaces.C.int;
    
    function Long_To_Pointer is 
        new Unchecked_Conversion (Win32.LONG, PointerToVBLong );
    function Long_To_Access_Int is 
        new Unchecked_Conversion (Win32.LONG, Access_Int );
    function Long_To_CharsPtr is 
        new Unchecked_Conversion (Win32.LONG, chars_ptr );

    PVBLong : PointerToVBLong;
    PVBString : chars_ptr;
    
    function pmatch( pLength : Win32.LONG; 
                     pString : Win32.LONG; 
                     pPointer : Win32.LONG; 
                     pPattern : Win32.LONG ) 
        return Win32.LONG is

        iLength : Interfaces.C.int;
        piPointer : Access_Int;
        uString : unBounded_String;
        uPattern : unBounded_String;
        res : StatusCode;

    begin
        PVBLong := Long_to_Pointer( pLength );
        iLength := Interfaces.C.int( PVBLong.all.L );

        Put( "iLength=" );
        Put( Integer(iLength), 10, 10 );
        Put_Line( "" );

        piPointer := Long_To_Access_Int( pPointer );

        Put( "@piPointer=" );
        Put( Integer( piPointer.all ), 10, 10);
        Put_Line( "" );

        piPointer.all := 1;

        Set_unBounded_String( uString, Value( Long_To_CharsPtr( pString ) ) );
        Set_unBounded_String( uPattern, Value( Long_To_CharsPtr( pPattern ) ) );

        Put_Line( "String=" & To_String( uString ) );
        Put_Line( "Pattern=" & To_String( uPattern ) );

        res := match( iLength, 
                      To_C( To_String( uString ) ), 
                      piPointer,
                      To_C( To_String( uPattern ) ) ); 

        Put( "@piPointer=" );
        Put( Integer( piPointer.all ), 10, 10);
        Put_Line( "" );
        Put( "@res=" );
        Put( Integer( res ), 10, 10);
        Put_Line( "" );
        
        return Win32.LONG( res );
    end pmatch;
          
    procedure Initialize_API is
        procedure Adainit;
        pragma Import (C, Adainit);
    begin
        Adainit;
    end Initialize_API;

    procedure Finalize_API is
        procedure Adafinal;
        pragma Import (C, Adafinal);
    begin
        Adafinal;
    end Finalize_API;
    
end BOS;

For the sake of completeness, BOS.DEF, BUILD.GPR and BUILD.BAT. Note that in BUILD.BAT, I specify match\match.o as an object file for gnatlink.

EXPORTS
    initialize_api  
    finalize_api    
    pmatch

project Build is
 for Source_Dirs use ( "./", "./match", "c:\mingw\lib\gcc\mingw32\4.2.1\**" );
 for Object_Dir use "debug";
 for Exec_Dir use "debug";
 for Main use ("bos");
     
 type Style_Type is ("debug", "release");
 Style : Style_Type := external ("STYLE", "debug");
     
 case Style is
  when "debug" =>
   for Object_Dir use "debug";
     
  when "release" =>
   for Object_Dir use "release";
   for Exec_Dir use ".";
 end case;
     
 package Builder is
     
  case Style is
   when "debug" =>
    for Default_Switches ("Ada")
    use ("-g");
    
   when others =>
    null;
  end case;
     
 end Builder;
 
 package Binder is
     
  case Style is
   when "debug" =>
    for Default_Switches ("Ada")
    use ("-E");
    
   when others =>
    null;
  end case;
     
 end Binder;
     
 package Compiler is
     
  case Style is
   when "debug" =>
    for Default_Switches ("Ada")
     use ( "-s", 
     "-gnato", "-fstack-check", "-g", "-gnat05"); --gnata
     
   when "release" =>
    for Default_Switches ("Ada")
     use ("-O2", "-fno-strict-aliasing", "-gnato", "-gnat05");
  end case;
     
 end Compiler;
     
     end Build;

 @echo off
setlocal
SET C_INCLUDE_PATH=C:\MinGW\lib\gcc\mingw32\4.2.1
set target=%1
if %1@==@ set target=debug
if not %1@==debug@ if not %1@==release@ set target=debug

echo Building %target% version of dll
c:\mingw\bin\gnat make -Pbuild -XSTYLE=%target% -LC:\MinGW\lib\gcc\mingw32\4.2.1\win32ada
if errorlevel 1 goto done
c:\mingw\bin\gnatbind -n -x %target%\bos.ali -IC:\MinGW\lib\gcc\mingw32\4.2.1\stdarg -IC:\MinGW\lib\gcc\mingw32\4.2.1\win32ada
if errorlevel 1 goto done
c:\mingw\bin\gnatlink -g -mdll -s -o %target%\bos.dll %target%\bos.ali -Xlinker --base-file=%target%\bos.base match\match.o 
if errorlevel 1 goto done
c:\mingw\bin\dlltool --dllname bos.dll --base-file %target%\bos.base --output-exp %target%\bos.exp --def bos.def
if errorlevel 1 goto done
c:\mingw\bin\gnatlink -g -mdll -s -o %target%\bos.dll %target%\bos.ali -Xlinker --base-file=%target%\bos.base %target%\bos.exp --enable-stdcall-fixup match\match.o
if errorlevel 1 goto done

if %target%==release upx -9 %target%\bos.dll

:done

Finally, the VB6 code being used to test it all. Please note that I'm using SetSubSys to turn the resulting EXE into a Console application. If you don't do that, the output from Ada's Put() statements will not be made visible.

It's not pretty code, but it does the job. By the way, if you don't do the StrConv, you'll be passing UTF-16 strings.

Declare Sub initialize_api Lib "debug\bos.dll" ()
Declare Sub finalize_api Lib "debug\bos.dll" ()
Declare Function pmatch Lib "debug\bos.dll" (ByVal mLength As Long, ByVal mString As Long, ByVal mPointer As Long, ByVal mPattern As Long) As Long

Sub Main()
    Dim s As String
    Dim r As String
    
    s = "12345b"
    Dim p As String
    p = "$#:'b'"
    p = StrConv(p, vbFromUnicode)
    s = StrConv(s, vbFromUnicode)
    Dim i As Long
    Dim j As Long
    dim k as long
    i = Lenb(s)
    j = 0
    initialize_api
    do
        k = pmatch(VarPtr(i), strptr(s), VarPtr(j), StrPtr(p))
        'msgbox k & " " & j
        if k <> 0 then exit do
    loop
    finalize_api
End Sub

Thursday, December 13, 2007

[Ada (GNAT)] Who said, "Ignorance is bliss"?

No comments: