Code-a-holic: GNAT/GCC

Showing posts with label GNAT/GCC. Show all posts

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

© Copyright Bruce M. Axtens., 2007

Monday, December 03, 2007

[Ada (GNAT/GCC)] VARPTR, GNAT and data "transput"

Okay, have got it figured (soli Deo gloria!)

The following listings demonstrate the passing of a two part Type containing two Singles from VB6 into a GNAT/GCC DLL. Once inside, the elements of the Type are swapped and control returns to VB6. VB6 then displays the results.

As before, the code has been worked out in the context of the afore-posted api project. If you want to play with this, just take the earlier work and tweak it appropriately.

First up, the additions to api.ads:

   function SwapSingles (
       VarPtr : in     Win32.LONG)
   return Win32.BOOL;
   ...
   pragma Export (DLL, SwapSingles );

Next, the additions to api.adb:

   with Ada.Exceptions;           use Ada.Exceptions;
   ...
    type Singles is
       record
          Part1 : Float;
          Part2 : Float;
       end record;

    type PointerToSingles is access Singles;

    function To_PointerToSingles is
    new Ada.Unchecked_Conversion (Win32.LONG, PointerToSingles );

    function SwapSingles (
          VarPtr : Win32.LONG)
      return Win32.BOOL is
        PSingles : PointerToSingles;
        FTemp1     : Float;
        FTemp2     : Float;
    begin
        PSingles:= To_PointerToSingles(VarPtr);
        FTemp1 := PSingles.All.Part1;
        FTemp2 := PSingles.All.Part2;
        PSingles.All.Part2 := FTemp1;
        PSingles.All.Part1 := FTemp2;
        return Win32.TRUE;
    exception
        when Constraint_Error =>
            return Win32.FALSE;
    end SwapSingles;

API.DEF must also be modified, adding swapsingles to the list of EXPORTS.

Next, some VB code to demonstrate ...

Declare Function SwapSingles Lib "api.dll" (ByVal ptr As Long) As Boolean
Type SinglesStruct
    Part1 as Single
    Part2 as Single
End Type
...
Dim Singles As SinglesStruct
Singles.Part1 = 123.456
Singles.Part2 = 654.321

Debug.Print "Before:"
Debug.Print "Singles.Part1 = " & Singles.Part1
Debug.Print "Singles.Part2 = " & Singles.Part2

If swapsingles(VarPtr(Singles)) = False Then
    Debug.Print "Constraint Error"
Else
    Debug.Print "After:"
    Debug.Print "Singles.Part1 = " & Singles.Part1
    Debug.Print "Singles.Part2 = " & Singles.Part2
End If

... and part of a sample output.

Before:
Singles.Part1 = 123.456
Singles.Part2 = 654.321
After:
Singles.Part1 = 654.321
Singles.Part2 = 123.456

The project that all this was part of was done in both GNAT/GCC and ObjectAda 7.2.2. Interestingly, ObjectAda's Float is equivalent to VB6's Double, whereas GNAT/GCC's Float is equivalent to VB6's Single. Does anyone know why?

By the way, regarding "transput", Wikipedia's article on Algol states:

ALGOL 60 as officially defined had no I/O facilities; implementations defined their own in ways that were rarely compatible with each other. In contrast, ALGOL 68 offered an extensive library of transput (ALGOL 68 parlance for Input/Output) facilities.

A extensive library of transput facilities is something you'll find in Protium, too.

© Copyright Bruce M. Axtens, 2007

Wednesday, November 28, 2007

[Ada (GNAT/GCC)] Passing data with VB6's VARPTR to Ada

In the current project, I've been trying to figure out how to pass data to Ada. Because I'll be passing Long, Double (Float), and two Types to emulate a LongLong and a DoubleDouble, I decided I'd use VB's VarPtr and have Ada sort the mess out on its side.

After the loss of a little hair, the reading of bits of Michael B. Feldman's Software Construction and Data Structures with Ada 95, and with help from Martin Krischik and Simon Wright, I came up with the following.

The code was worked out in the context of the afore-posted api project. If you want to play with this, just take the earlier work and stuff this into it.

First up, the additions to api.ads:

   function HandlePointer (
       Left : in     Win32.LONG)
   return Win32.LONG;
   ...
   pragma Export (DLL, HandlePointer );

Next, the additions to api.adb:

   function HandlePointer (
         Left : in     Win32.LONG)
     return Win32.LONG is

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

      type PointerToLongRec is access LongRec;

      function Conv is
      new Unchecked_Conversion (Win32.LONG, PointerToLongRec );

      PLongRec : PointerToLongRec;
   begin
      PLongRec := Conv(Left);
      return PLongRec.All.L;
   end HandlePointer;

Next, some VB code to demonstrate ...

Declare Function handlepointer Lib "release\api.dll" (ByVal x As Long) As Long
Dim i As Long
i = 1001
Debug.Print "i="; i
Debug.Print "varptr(i)="; VarPtr(i)
Debug.Print "what ada thinks is pointed to by varptr(i)="; handlepointer(VarPtr(i))

... and a sample output.

i= 1001 
varptr(i)= 1309644 
what ada thinks is pointed to by varptr(i)= 1001 

I'm in the process now of working out how to access the LongLong and DoubleDouble Types. Shall keep you posted.

By the way, the return value will eventually be a pointer as well. That'll keep the VB programmer on his toes.

© Copyright Bruce M. Axtens, 2007

Monday, November 26, 2007

[Ada (GNAT/GCC)] Better build automation

Just after I notified comp.lang.ada of my posting re GNAT/GPL, Martin Krischik wrote suggesting I use a .gpr file and gnat make rather than a direct reference to gcc.

After reading a friendly manual, I came up with the following .grp file and a batch file to control it.

I have stayed with the batch file, simply because I can't yet see how to have a multiple-program linkage (gnatlink, dlltool and gnatlink a second time).

First, build.gpr

project Build is
 for Source_Dirs use ( "./", "c:\mingw\lib\gcc\mingw32\4.2.1\**" );
 for Object_Dir use "debug";
 for Exec_Dir use "debug";
 for Main use ("api");
     
 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 Compiler is
     
  case Style is
   when "debug" =>
    for Default_Switches ("Ada")
     use ( "-s", 
     "-gnata",
     "-gnato",
     "-gnatE");
     
   when "release" =>
    for Default_Switches ("Ada")
     use ("-O2", "-fno-strict-aliasing");
  end case;
     
 end Compiler;
     
     end Build;

And then, build.bat. Note the call to UPX, which compresses the release version of the .DLL. Note also that the debug and release subdirectories must already exist (though it wouldn't have been difficult to check-for-and-create-if-missing.)

 @echo off
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
gnat make -Pbuild -XSTYLE=%target%
gnatbind -n -x %target%\api.ali -IC:\MinGW\lib\gcc\mingw32\4.2.1\stdarg -IC:\MinGW\lib\gcc\mingw32\4.2.1\win32ada
gnatlink -g -mdll -s -o %target%\api.dll %target%\api.ali -Xlinker --base-file=%target%\api.base  
dlltool --dllname api.dll --base-file %target%\api.base --output-exp %target%\api.exp --def api.def
gnatlink -g -mdll -s -o %target%\api.dll %target%\api.ali -Xlinker --base-file=%target%\api.base %target%\api.exp   

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

Trust that's helpful.

© Copyright Bruce M. Axtens, 2007

Friday, November 23, 2007

[Ada (GNAT/GCC)] Creating DLLs for VB6

And finally, after much prayer and perspiration, the GNAT/GCC version. Again, thanks to Roger Pearse for The Noddy Guide to using ADA code with Visual Basic. I'm sure there was someone else [This space set aside for an attribution.]

First up, api.ads, which declares the functions and exports them.

function Factorial, which accepts a Win32.LONG and returns a Win32.LONG (I gave up on C.int as it was too small for a Factorial of 16)
function GetCount, which returns the value of the global Count (another Win32.LONG)
procedure Mangle, which accepts a Win32.LPWSTR and attempts the same dangerous stuff that Bob6 does in the ObjectAda version.
function Pattern, which returns a long pointer to some string data
procedures Initialize_API, and Finalize_API, which I understand are mandatory. (If someone knows better, please tell me.)

with Interfaces.C; use Interfaces;
with Win32; use Win32;
package API is
   Count : Win32.LONG := 0;
   function Factorial (Val : Win32.LONG) return Win32.LONG;
   function GetCount return Win32.LONG;
   procedure Mangle( Ptr : Win32.LPWSTR );
   function Pattern return Win32.LPWSTR;
   
   procedure Initialize_API;
   procedure Finalize_API;

private
   pragma Export (DLL, Initialize_API);
   pragma Export (DLL, Finalize_API);
   --pragma Export (StdCall, Count);
   pragma Export (DLL, GetCount );
   pragma Export (DLL, Factorial );
   pragma Export (DLL, Mangle );
   pragma Export (DLL, Pattern );
end API;

Next, api.adb, where the declarations are explained.

I'm still working through the issue of what to do with Mangle. Perhaps two routines are needed. The first to ask the DLL how much space is needed, with VB the allocating it, and the second then actually poking the data into the allocated space.

Pattern returns a pointer to the string data. I rediscovered the technique for reading it out and that's in the VB code below. It also seems that, for as long as the DLL is loaded, the data stored in foo is available for transfer.

with Interfaces.C;
use Interfaces.C;
with Win32; use Win32;
with Win32.Winmain;
with Win32.Winbase;
with System;

package body API is
   function Factorial (Val : Win32.LONG) return Win32.LONG is
      Fact : Win32.LONG := 1;
   begin
      Count := Count + 1;
      for K in 1 .. Val loop
         Fact := Fact * K;
      end loop;
      return Fact;
   end Factorial;

   function GetCount return Win32.LONG is
   begin
      return Count;
   end GetCount;
   
   procedure Mangle( Ptr : Win32.LPWSTR ) is
      lp : Win32.lpwstr;
      foo : constant Win32.WCHAR_Array := "foo man chew" & Win32.Wide_Nul;
   begin
      lp := Win32.Winbase.lstrcpyW( Ptr, Win32.Addr(foo) );
   end Mangle;

   function Pattern return Win32.LPWSTR is
    foo : constant Win32.WCHAR_Array := "martinet mongoose manticore" & Win32.Wide_Nul;
   begin
      return Win32.Addr(foo);
   end Pattern;

   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 API;

api.def lists the symbols exported, and is needed by gnatdll.

EXPORTS
 factorial       
 mangle
 initialize_api  
 finalize_api    
 pattern
 getcount

Now, pulling it all together requires some handwaving on the commandline. From one of the demos I modified the make.bat to look like this:

 @echo off
REM first built a relocatable Ada DLL
echo Build the Ada dll
gnat make api -IC:\MinGW\lib\gcc\mingw32\4.2.1\stdarg -IC:\MinGW\lib\gcc\mingw32\4.2.1\win32ada 
gnatbind -n -x api.ali -IC:\MinGW\lib\gcc\mingw32\4.2.1\stdarg -IC:\MinGW\lib\gcc\mingw32\4.2.1\win32ada
gnatlink -g -mdll -s -o api.dll api.ali -Xlinker --base-file=api.base
dlltool --dllname api.dll --base-file api.base --output-exp api.exp --def api.def
gnatlink -g -mdll -s -o api.dll api.ali -Xlinker --base-file=api.base api.exp

The output from a run of these is as follows:

C:\msys\1.0\home\Bruce>make
Build the Ada dll
gcc -c -IC:\MinGW\lib\gcc\mingw32\4.2.1\stdarg -IC:\MinGW\lib\gcc\mingw32\4.2.1\win32ada api.adb
Warning: resolving _finalize_api by linking to _finalize_api@0
Use --enable-stdcall-fixup to disable these warnings
Use --disable-stdcall-fixup to disable these fixups
Warning: resolving _getcount by linking to _getcount@0
Warning: resolving _initialize_api by linking to _initialize_api@0
Warning: resolving _mangle by linking to _mangle@4
Warning: resolving _pattern by linking to _pattern@0
Warning: resolving _factorial by linking to _factorial@4
C:\msys\1.0\home\Bruce>

Now the VB code. Take note of a few things:

Exporting as DLL generates decorated names, but dlltool was able to resolve the decorated ones with the undecorated ones specified in api.def
For reasons I remember reading somewhere, initialize_api and finalize_api are mandatory, and must be the first and last calls to the DLL
Seeing as woof woof woof woof is longer than foo man chew, s ends up containing foo man chew f woof
As mentioned before, I rediscovered some code for getting data from a pointer and put that in. It's the PointerToString function at the bottom.

Declare Sub initialize_api Lib "api.dll" ()
Declare Function factorial Lib "api.dll" (ByVal x As Long) As Long
Declare Function getcount Lib "api.dll" () As Long
Declare Function pattern Lib "api.dll" () As Long
Declare Sub mangle Lib "api.dll" (ByVal x As Long)
Declare Sub finalize_api Lib "api.dll" ()

' Declaration of the function which copies the character string
Private Declare Function lstrcpy Lib "Kernel32.Dll " Alias "lstrcpyW" (LpszString1 As Any, LpszString2 As Any) As Long
 
' Declaration of the function which returns the length in the character string
Private Declare Function lstrlen Lib "Kernel32.Dll " Alias "lstrlenW" (ByVal lpszString As Long) As Long
    
Sub main()
    Dim s As String
    s = "woof woof woof woof"
    initialize_api
    Dim i As Long
    For i = 1 To 16
    Debug.Print factorial(i);
    Next
    Debug.Print
    mangle StrPtr(s)
    Debug.Print Len(s), s
    Dim ptr As Long
    ptr = pattern()
    Debug.Print PointerToString(ptr)
    finalize_api
End Sub

' Converting the pointer to the character string
Function PointerToString(lngPointer As Long) As String
    Dim bytBuffer(255) As Byte
    ' Copying the character string which the pointer points to byte array
    lstrcpy bytBuffer(0), ByVal lngPointer
    ' Cutoff after the null character
    PointerToString = Left(bytBuffer, lstrlen(lngPointer))
End Function

Finally, a sample run under VB6

 1  2  6  24  120  720  5040  40320  362880  3628800  39916800  479001600  1932053504  1278945280  2004310016  2004189184 
 19           foo man chew f woof
martinet mongoose manticore

Next? Well, there's the issue of how to export overloaded functions and procedures. And there's the question of how to pass in complex data types, like records and the like. I'll keep you posted.

(By the way, I'm not doing this merely for the fun of it, but also in pursuit of the fulfillment of my employer's expectations. So more will follow.)

© Copyright Bruce M. Axtens, 2007