[FORTRAN] Making a DLL for VB6

As a break from trying to figure out how to get a pattern matching library DLLified (and UTF-32 sensitive), my boss gave me something else to do, something on the one hand similar (wrap something in a DLL) and on the other quite different (wrap two knapsack algorithms done in Fortran 90).

The knapsack code is derived from

Algorithm 4.9, Donald Kreher and Douglas Stinson, Combinatorial Algorithms, CRC Press, 1999, page 125.

and was downloaded from FORTRAN Source Codes, specifically, the COMBO library. Many thanks to John Burkardt for making this resources available.

The files used from the COMBO library were knapsack_01.f90, knapsack_rational.f90, knapsack_reorder.f90, rvec_backtrack.f90 and r_swap.f90, and were compiled using Compaq Visual Fortran.

Seeing as CVF is no longer available (except perhaps on eBay) you might get away with the Intel® Fortran Compiler for Windows, SilverFrost's FTN95 or g95.

Don't try it with Watcom Fortran, however, because that only does Fortran 77. Mind you, if the algorithms you're wrapping are F77 ones from NIST's 'Dictionary of Algorithms and Data Structures' or Steven Skiena's The Stony Brook Algorithm Repository you may do okay with the Watcom offering or even GNU's g77.

I really like Fortran. I remember writing some VAX-11 FORTRAN back in 1983 (along with a bit more VAX-11 COBOL) and found it quite powerful and expressive. I know that there's been a fairly widespread pooh-pooh-ing of Fortran in recent years, but I try not to be influenced by peer-group pressure, preferring to actually see for myself whether a language is any good or not.

Okay, off the soap box and down to the code. I'm not going to bother posting all the COMBO code, just what I wrote to wrap it.

These are the three exposed routines and have essentially the same framework: a subroutine header, two declarations controlling symbol names and method of access, the call to the COMBO routine, the return and the end of subroutine. Really, really, simple. Gobsmackingly simple, compared to some other languages I could mention. Rather embarrasing really ... so little to show.

If you're wondering why I explicitly state that the parameters are being passed by reference (!dec$ attributes reference ...), it's because a side effect of specifying "stdcall" is that it forces the passing mechanism into pass-by-value, and in this case, quite a few of the parameters are being modified by the subroutine.

!BOAL0.f90 !FUNCTIONS/SUBROUTINES exported from BOAL0.dll: !stdcall forces all parameters to pass-by-value, !thus the 'attributes reference' declaration subroutine Knapsack01( n, mass_limit, p, w, x, mass, profit ) !DEC$ ATTRIBUTES DLLEXPORT, STDCALL, ALIAS : "Knapsack01" :: Knapsack01 !dec$ attributes reference :: n, mass_limit, p, w, x, mass, profit call knapsack_01 ( n, mass_limit, p, w, x, mass, profit ) return end subroutine Knapsack01 subroutine KnapsackRational ( n, mass_limit, p, w, x, mass, profit ) !DEC$ ATTRIBUTES DLLEXPORT, STDCALL, ALIAS : "KnapsackRational" :: KnapsackRational !dec$ attributes reference :: n, mass_limit, p, w, x, mass, profit call knapsack_rational ( n, mass_limit, p, w, x, mass, profit ) return end subroutine KnapsackRational subroutine KnapsackReorder ( n, p, w ) !DEC$ ATTRIBUTES DLLEXPORT, STDCALL, ALIAS : "KnapsackReorder" :: KnapsackReorder !dec$ attributes reference :: n, p, w call knapsack_reorder ( n, p, w ) return end subroutine KnapsackReorder

The other routines are linked in during the compile and I end up with a nice little .DLL.

Okay, so maybe there's something more to show on the VB6 side.

First off, the declares. VB6 defaults to pass-by-reference, thus the missing "ByRef" ahead of each parameter.

Declare Sub KnapsackReorder Lib "BOAL0.dll" (n As Integer, p As Single, w As Single) Declare Sub Knapsack01 Lib "BOAL0.dll" (n As Integer, mass_limit As Single, p As Single, w As Single, x As Single, mass As Single, profit As Single) Declare Sub KnapsackRational Lib "BOAL0.dll" (n As Integer, mass_limit As Single, p As Single, w As Single, x As Single, mass As Single, profit As Single)

Next the test code which is derived from TEST094 and TEST095 found inside COMBO's combo_prb.f90.

Do note that the floating point variables are defined here as Single. This seems to be the best match to an undecorated Fortran REAL. Maybe if I'd tweaked the COMBO code to REAL*8, I could have used Double on the VB6 side.

Sub main() Dim i As Integer Dim mass As Single Const mass_limit As Single = 26# Dim p(4) As Single Dim profit As Single Dim w(4) As Single Dim x(4) As Single Const n As Integer = 4 p(0) = 24# p(1) = 13# p(2) = 23# p(3) = 15# p(4) = 16# w(0) = 12# w(1) = 7# w(2) = 11# w(3) = 8# w(4) = 9# Debug.Print " " Debug.Print "TEST094" Debug.Print " KNAPSACK_REORDER reorders the knapsack data." Debug.Print " KNAPSACK_01 solves the 0/1 knapsack problem." Debug.Print " " Debug.Print "Object", "Profit", "Mass", "Profit Density" Debug.Print " " For i = 0 To n Debug.Print i, p(i), w(i), p(i) / w(i) Next KnapsackReorder n, p(0), w(0) Debug.Print " " Debug.Print " After reordering by Profit Density:" Debug.Print " " Debug.Print "Object", "Profit", "Mass", "Profit Density" Debug.Print " " For i = 0 To n Debug.Print i, p(i), w(i), p(i) / w(i) Next Debug.Print " " Debug.Print " Total mass restriction is " & mass_limit Knapsack01 n, mass_limit, p(0), w(0), x(0), mass, profit Debug.Print " " Debug.Print "Object", "Density", "Choice", "Profit", "Mass" Debug.Print " " For i = 0 To n Debug.Print i, p(i) / w(i), x(i), x(i) * p(i), x(i) * w(i) Next Debug.Print " " Debug.Print " Total:", , , profit, mass '-- p(0) = 24# p(1) = 13# p(2) = 23# p(3) = 15# p(4) = 16# w(0) = 12# w(1) = 7# w(2) = 11# w(3) = 8# w(4) = 9# Debug.Print " " Debug.Print "TEST094" Debug.Print " KNAPSACK_REORDER reorders the knapsack data." Debug.Print " KNAPSACK_RATIONAL solves the rational knapsack problem." Debug.Print " " Debug.Print "Object", "Profit", "Mass", "Profit Density" Debug.Print " " For i = 0 To n Debug.Print i, p(i), w(i), p(i) / w(i) Next KnapsackReorder n, p(0), w(0) Debug.Print " " Debug.Print " After reordering by Profit Density:" Debug.Print " " Debug.Print "Object", "Profit", "Mass", "Profit Density" Debug.Print " " For i = 0 To n Debug.Print i, p(i), w(i), p(i) / w(i) Next Debug.Print " " Debug.Print " Total mass restriction is " & mass_limit KnapsackRational n, mass_limit, p(0), w(0), x(0), mass, profit Debug.Print " " Debug.Print "Object", "Density", "Choice", "Profit", "Mass" Debug.Print " " For i = 0 To n Debug.Print i, p(i) / w(i), x(i), x(i) * p(i), x(i) * w(i) Next Debug.Print " " Debug.Print " Total:", , , profit, mass End Sub

Hmm ... nothing much amazing there either. But that's how it was with wrapping the Fortran. Simple and powerful at the same time. So far as I'm concerned, if we ever have to rewrite Protium, Fortran's going to be very near the top of the list.

© Copyright Bruce M. Axtens., 2007

[Visual BASIC 6] BOOST (v2)

I revisited BOOST this week. A friend had pointed out to me some time back that /P: and /L: were a bit of a pain when one wanted to speed something up quickly, or kill it quickly. So this version changes the command line handling.

This version also demonstrates how to kill a process. In fact it kills every process of the same name. I wish I'd had this a couple of years ago when I was doing stuff with Excel -- I'd end up with multiple Excel sessions which I would then have to kill off one-by-one through the Task Manager. (I eventually ended up installing Cygwin so that I could script the process.)

If you remember the original VBScript of BOOST and the first VB6 version, you'll see some similarities.

I've given up on using setsubsys in favour of using VBAdvance (which is now freeware) to handle the compile-to-console-app process. I'm still compressing the app using UPX.

First a few constants and the declarations, found on vb.mvps.org, for doing console I/O.

Option Explicit Const KILL_PROCESS = 0 '0 Const LOW_PRIORITY = 64 '1 Const BELOWNORMAL_PRIORITY = 16384 '2 Const NORMAL_PRIORITY = 32 '3 Const ABOVENORMAL_PRIORITY = 32768 '4 Const HIGH_PRIORITY = 256 '5 Const REALTIME_PRIORITY = 128 '6 Private Declare Function GetStdOutHandle Lib "kernel32" _ Alias "GetStdHandle" _ (Optional ByVal HandleType As Long = -11) As Long Private Declare Function WriteFile Lib "kernel32" _ (ByVal hFile As Long, _ ByVal lpBuffer As String, _ ByVal cToWrite As Long, _ ByRef cWritten As Long, _ Optional ByVal lpOverlapped As Long) As Long 'To keep things simple, wrap these two APIs in a single helper function like so: Private Function ConsoleWrite(sText As String) As Long WriteFile GetStdOutHandle, ByVal sText, Len(sText), ConsoleWrite End Function

Next, a few supporting functions. First off the rank, is an invocation syntax display. Notice that priority can now be specified either by a number (0 to kill, 1-6 for low to realtime) or by name (kill, low, belownormal, normal, abovenormal, high, realtime).

Sub Syntax() ConsoleWrite ("Syntax:" & vbNewLine & _ vbTab & "Boost {processname} {runlevel}" & vbNewLine & _ "Run level as number:" & vbNewLine & _ vbTab & "0 = KILL_PROCESS" & vbNewLine & _ vbTab & "1 = LOW_PRIORITY" & vbNewLine & _ vbTab & "2 = BELOWNORMAL_PRIORITY" & vbNewLine & _ vbTab & "3 = NORMAL_PRIORITY" & vbNewLine & _ vbTab & "4 = ABOVENORMAL_PRIORITY" & vbNewLine & _ vbTab & "5 = HIGH_PRIORITY" & vbNewLine & _ vbTab & "6 = REALTIME_PRIORITY" & vbNewLine & vbNewLine & vbNewLine & _ "Run level as text:" & vbNewLine & _ vbTab & "kill = KILL_PROCESS" & vbNewLine & _ vbTab & "low = LOW_PRIORITY" & vbNewLine & _ vbTab & "belownormal = BELOWNORMAL_PRIORITY" & vbNewLine & _ vbTab & "normal = NORMAL_PRIORITY" & vbNewLine & _ vbTab & "abovenormal = ABOVENORMAL_PRIORITY" & vbNewLine & _ vbTab & "high = HIGH_PRIORITY" & vbNewLine & _ vbTab & "realtime = REALTIME_PRIORITY" & vbNewLine) End Sub

Second, the command line parser. This splits on space and tab and is based on code found at microsoft.public.vb.winapi

Function GetCommandLine(Optional MaxArgs) As Variant 'Declare variables. Dim C As String Dim CmdLine As String Dim CmdLnLen As Integer Dim InArg As Boolean Dim i As Integer Dim NumArgs As Integer Dim ArgArray As Variant 'See if MaxArgs was provided. If IsMissing(MaxArgs) Then MaxArgs = 10 'Make array of the correct size. ReDim ArgArray(MaxArgs - 1) NumArgs = 0: InArg = False 'Get command line arguments. CmdLine = Command() CmdLnLen = Len(CmdLine) 'Go thru command line one character 'at a time. For i = 1 To CmdLnLen C = Mid(CmdLine, i, 1) 'Test for space or tab. If (C <> " " And C <> vbTab) Then 'Neither space nor tab. 'Test if already in argument. If Not InArg Then 'New argument begins. 'Test for too many arguments. If NumArgs = MaxArgs Then Exit For NumArgs = NumArgs + 1 InArg = True End If 'Concatenate character to current argument. ArgArray(NumArgs - 1) = ArgArray(NumArgs - 1) & C Else 'Found a space or tab. 'Set InArg flag to False. InArg = False End If Next i 'Resize array just enough to hold arguments. ReDim Preserve ArgArray(NumArgs - 1) 'Return Array in Function name. GetCommandLine = ArgArray '() End Function

Third, the two routines which wrap the WMI functions to set priority and to kill process. The latter was found at tek-tips. If I remember correctly, the places in each routine where it says

sComputer = "."

could, in fact, have some other computer's name. If you had sufficient privilege you could be tweaking or killing a process on someone else's machine.

Function SetPriority(sProcess As String, nPriority As Integer) As Boolean Dim sComputer As String Dim oWMIService As Object Dim cProcesses As Object Dim oProcess As Object Dim bDone As Boolean bDone = False sComputer = "." Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2") On Error Resume Next Set cProcesses = oWMIService.ExecQuery _ ("Select * from Win32_Process Where Name = '" & sProcess & "'") For Each oProcess In cProcesses oProcess.SetPriority (nPriority) If Err.Number <> 0 Then GoTo DoNext End If bDone = True DoNext: Next On Error GoTo 0 SetPriority = bDone End Function Function KillProcess(sProcess As String) As Integer Dim oWMIService As Object Dim sComputer As String Dim oProcess As Object Dim nDone As Integer nDone = 0 sComputer = "." 'this computer Set oWMIService = GetObject("winmgmts:") For Each oProcess In oWMIService.InstancesOf("Win32_process") If LCase(oProcess.Name) = LCase(sProcess) Then oProcess.Terminate nDone = nDone + 1 End If Next KillProcess = nDone End Function

Finally, the Main subroutine. Notice the additions to the priorities collection. Note also the change in the way the command line is handled.

Because there's no .Exists method on Collections, the .Item call is wrapped in an 'On Error' so that a non-existent item situation is caught appropriately.

Sub Main() Dim sLevel As String Dim nLevel As Integer Dim sProcess As String Dim sCommand As String Dim nInstances As Integer Dim dPriorities As New Collection dPriorities.Add Item:=KILL_PROCESS, Key:="kill" dPriorities.Add Item:=LOW_PRIORITY, Key:="low" dPriorities.Add Item:=BELOWNORMAL_PRIORITY, Key:="belownormal" dPriorities.Add Item:=NORMAL_PRIORITY, Key:="normal" dPriorities.Add Item:=ABOVENORMAL_PRIORITY, Key:="abovenormal" dPriorities.Add Item:=HIGH_PRIORITY, Key:="high" dPriorities.Add Item:=REALTIME_PRIORITY, Key:="realtime" dPriorities.Add Item:=KILL_PROCESS, Key:="0" dPriorities.Add Item:=LOW_PRIORITY, Key:="1" dPriorities.Add Item:=BELOWNORMAL_PRIORITY, Key:="2" dPriorities.Add Item:=NORMAL_PRIORITY, Key:="3" dPriorities.Add Item:=ABOVENORMAL_PRIORITY, Key:="4" dPriorities.Add Item:=HIGH_PRIORITY, Key:="5" dPriorities.Add Item:=REALTIME_PRIORITY, Key:="6" Dim aArgs As Variant If Command() = "" Then Syntax End End If aArgs = GetCommandLine(2) sProcess = aArgs(0) sLevel = aArgs(1) If sProcess = "" Or sLevel = "" Then Syntax End End If On Error Resume Next nLevel = dPriorities.Item(sLevel) If Err.Number = 5 Then ConsoleWrite "Invalid selection of runlevel." & vbNewLine Syntax End End If On Error GoTo 0 If nLevel = 0 Then nInstances = KillProcess(sProcess) If nInstances = 0 Then ConsoleWrite "No instances of " & sProcess & " found to kill" & vbNewLine Else ConsoleWrite nInstances & " " & IIf(nInstances > 1, "instances", "instance") & " of " & sProcess & " killed." & vbNewLine End If Else ConsoleWrite sProcess & IIf(SetPriority(sProcess, nLevel), _ " boosted", " NOT boosted") & _ " to priority " & sLevel & " (" & nLevel & ")." & vbNewLine End If End Sub

What's next with this thing? I suppose one could explore the possibility of influencing the lives of applications on other computers:

BOOST Skype.exe kill /C:GUEST_01

There's also the fact that the commandline parser doesn't properly handle double-quoted names. If an .exe had a space it its name, you wouldn't be able use BOOST on it.

Finally, here's a short batch file (killall.bat) I use for killing applications en masse. It was originally designed to get around the 'typing the /P and /L' issue, but I'm so used to using it now ...

@echo off :loop if %1@==@ goto done c:\bin\boost %1 kill shift goto loop :done

An example invocation:

killall excel.exe outlook.exe

© Copyright Bruce M. Axtens, 2007

[Programming] Okay, Ignorance is Bliss ...

If by Ignorance you mean an implementation of the Bliss programming language, then yes, Ignorance is Bliss.

After two and half weeks of Ada, I had to have a break. I wandered over to the Retrocomputing Museum and downloaded the Ignorance source code. While I was at it I also downloaded the source for CUPL, the Cornell University Programming Language. Interestingly, the same interpreter also works for CORC, the CORnell Compiler. The man behind the website, Eric Raymond, has the following, less than flattering, words to describe CUPL:

"Another hideous old design, CUPL — Cornell University Programming Language. It looks something like a really archaic BASIC with linear-algebra builtins."

And what's wrong with BASIC and linear algebra? (That was a rhetorical question.)

I've been able to get CUPL to work, but haven't had any success with Ignorance. Or, for that matter, with JOSS.

To find out more about these languages, HOPL is your friend: Bliss, CUPL and JOSS.

as is Wikipedia: Bliss, CORC (CUPL precursor) and JOSS.

© Copyright Bruce M. Axtens., 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

[Google] AdSense and Analytics

On the suggestion of my eldest, I've added Google Analytics. In the next couple of days I should hear back from Google AdSense and will trial having Google Ads on the page. If it earns, fine. If not, I think I'll give it a miss. "Suck it and see," as my late father would have said.

[Ada (GNAT)] A 32bit GNAT.Spitbol.*

It is said that, "a wise man knows his own turnips." In my case, I've run into some difficulty converting GNAT.Spitbol to UTF-32. The compiler error messages are marvellously helpful, but I'm a newbie to Ada and ... yeah, well, you get the idea.

The source code is up on Box.net, if you feel so inclined as to download it and tell me where I'm going wrong.

[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