[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

[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

[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

[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

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

As promised, the GNAT/GPL code. Based on Roger Pearse's The Noddy Guide to using ADA code with Visual Basic.

How I ended up with the names api.ads, api.adb and api.def is an artefact from something I was reading. [This space set aside for an attribution.]

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

• function Factorial, which accepts a C.int and returns a C.int
• procedure Mangle, which accepts a Win32.LPWSTR and attempts the same dangerous stuff that Bob6 does in the ObjectAda version. Still working on this one.
• function Pattern, which returns a Win32.LPWSTR
• 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 : C.int := 0; function Factorial (Val : C.int) return C.int; procedure Mangle( Ptr : Win32.LPWSTR ); function Pattern return Win32.LPWSTR; procedure Initialize_API; procedure Finalize_API; -- Initialization & Finalization routines. More in the next section. private pragma Export (DLL, Initialize_API); pragma Export (DLL, Finalize_API); --pragma Export (StdCall, Count); pragma Export (DLL, Factorial ); pragma Export (DLL, Mangle ); pragma Export (DLL, Pattern ); end API;

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

Mangle replaces the incoming string with something of its own. If the incoming string is larger or the same size then everything's more or less okay. (Less in the latter case, but at least it doesn't crash.) However, if the incoming string is shorter, VB truncates up to the length it knows about, and who knows what damage we've done with whatever gets overwritten by the rest of foo.

Pattern returns a pointer to the string data. Not knowing a lot about Ada, I don't know if the contents of foo will still be there by the time VB looks it and reads out.

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 : C.int) return C.int is Fact : C.int := 1; begin Count := Count + 1; for K in 1 .. Val loop Fact := Fact * K; end loop; return Fact; end Factorial; procedure Mangle( Ptr : Win32.LPWSTR ) is lp : Win32.lpwstr; foo : Wide_String := Wide_String'("foo man chew"); begin lp := Win32.Winbase.lstrcpyW( Ptr, Win32.Addr(foo) ); end Mangle; function Pattern return Win32.LPWSTR is foo : Wide_String := Wide_String'("foo man chew"); 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

Now, pulling it all together requires some handwaving on the commandline.

gnat make api -Ic:\gnat\2007\include\win32ada gnatdll -e api.def -d api.dll api.ali -Ic:\gnat\2007\lib\win32ada

The output from a run of these is as follows:

C:\Docume...ts\BO_DLL>gnat make api -Ic:\gnat\2007\include\win32ada gcc -c -Ic:\gnat\2007\include\win32ada api.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\win32.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\win32-winbase.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\win32-winmain.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\stdarg.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\stdarg-impl.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\win32-utils.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\win32-windef.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\win32-winnt.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\stdarg-machine.ads C:\Documen...ts\BO_DLL>gnatdll -e api.def -d api.dll api.ali -Ic:\gnat\2007\lib\win32ada Building relocatable DLL... make api.dll and libapi.a 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 _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 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 _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

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

• Exporting as DLL generates decorated names, but gnatdll 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
  woof

Declare Sub initialize_api Lib "api.dll" () Declare Function factorial Lib "api.dll" (ByVal x As Integer) As Integer 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" () Sub main() Dim s As String s = "woof woof woof woof" initialize_api Debug.Print factorial(3) mangle StrPtr(s) Debug.Print Len(s), s finalize_api End Sub

Next stop is to get this working with "GNAT/GCC MS-Windows MinGW 4.2.1 R0". I would prefer to be working under the GMGPL.

© Copyright Bruce M. Axtens., 2007

[Ada (ObjectAda 7.2.2)] Creating VB6 DLLs

Creating DLLs for use by VB6 seems to be somewhat of a dark art. From what Roger Pearse, in his The Noddy Guide to using ADA code with Visual Basic says, it doesn't appear to be something easily achieved.

So far I've achieved it, to a certain extent, with ObjectAda and GNAT/GPL. The code for the ObjectAda implementation is below. I'll post the GNAT/GPL stuff in the next couple of days, God willing.

BO_DLib.adb, BO_D.adb and BO_D.ads are all based, albeit rather loosely, on sample files in winapi\samples\petzold\ch19\edrlib\

First up, BO_DLib.adb

-- ====================================================================================== -- -- -- -- Converted from Programming Windows 95 / Charles Petzold -- 4th ed. -- -- Chapter 19 EDRLIB.C: Easy Drawing Routine Library Module -- -- -- -- ====================================================================================== -- with BO_B; procedure BO_BLib is begin null; end BO_BLib;

Next, the spec file, BO_D.ads

There are six routines:

• procedure Bob1 calls dobox to show a messagebox.
• function Bob2 returns a long value, 1.
• function Bob3 receives a long and adds 21 to it.
• procedure Bob4 receives a long pointer to a string and passes it to dobox for display.
  I can pass Unicode to it and have it rendered appropriately.
• function Bob5 receives a long pointer to a string and returns a long being the length of the string.
• function Bob6 receives a long pointer to a string and catenates a string to it.
  "Danger, Will Robinson!" ... this is not how to do it and VB complains bitterly.

Okay, there are seven routines, but dobox isn't exported. It takes a pointer to a wide string and passes it to Win32.Winuser.MessageBoxW. I got dobox from a sample file as well.

-- ====================================================================================== -- -- -- -- Converted from Programming Windows 95 / Charles Petzold -- 4th ed. -- -- Chapter 19 EDRLIB.C: Easy Drawing Routine Library Module -- -- -- -- ====================================================================================== -- with Win32.Windef; package BO_B is procedure bob1; function Bob2 return Win32.LONG; function bob3 ( arg : Win32.LONG ) return Win32.LONG; procedure Bob4( Arg : win32.LPCWSTR ); function bob5( Arg : win32.PCWSTR ) return win32.LONG; procedure dobox (msg : Win32.PCWSTR); procedure Bob6( Arg : Win32.LPWSTR ); pragma Export (DLL_Stdcall, Bob1, "Bob1"); pragma export (DLL_Stdcall, Bob2, "Bob2"); pragma export (DLL_Stdcall, Bob3, "Bob3"); pragma Export (DLL_Stdcall, Bob4, "Bob4"); pragma Export (DLL_Stdcall, Bob5, "Bob5"); pragma Export (DLL_Stdcall, Bob6, "Bob6"); end BO_B;

And, finally, BO_D.adb, where the definitions given in BO_D are fleshed out.

-- ====================================================================================== -- -- -- -- Converted from Programming Windows 95 / Charles Petzold -- 4th ed. -- -- Chapter 19 EDRLIB.C: Easy Drawing Routine Library Module -- -- -- -- ====================================================================================== -- with Interfaces.C; with interfaces.C.Strings; use interfaces; with Ada.Unchecked_Conversion; with Interfaces.C.Strings; with System; with Win32.Crt.Direct; with Win32.Crt.Stdlib; with Win32.Winbase; with Win32.Windef; with Win32.Wingdi; with Win32.Winmain; with Win32.Utils; with Win32.Winuser; with win32; use win32; with Win32.windowsx; package body BO_B is procedure bob1 is msg : Win32.PCWSTR; HELLOMSG : constant WCHAR_Array := "Hello" & Wide_Nul; begin Msg := Addr(HELLOMSG); dobox(Msg); end bob1; function Bob2 return Win32.LONG is begin return 1; end bob2; function bob3 ( arg : Win32.LONG ) return Win32.LONG is use type Win32.LONG; sum : Win32.LONG; begin Sum := Arg + 21; return Sum; end Bob3; procedure Bob4( Arg : win32.PCWSTR ) is begin dobox(arg); end Bob4; function Bob5( Arg : win32.PCWSTR ) return win32.LONG is Arguments_Length : constant Win32.LONG := Win32.LONG (Win32.Winbase.lstrlenW (Arg)); begin return Arguments_Length; end Bob5; procedure Bob6( Arg : Win32.LPWSTR ) is H : Wide_String := Wide_String'("doo dah, doo dah"); c : Win32.lpwstr; begin c := win32.winbase.lstrcatW( Arg, Addr(H) ); end Bob6; procedure dobox (msg : Win32.PCWSTR) is IResult : Win32.INT; begin iResult := Win32.Winuser.MessageBoxW(System.Null_Address, Msg, Addr("Title"), 0); end dobox; end BO_B;

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

• I declared the functions and procedures as DLL_Stdcall in BO_D.ads so the routines come in decorated, thus the use of Alias in the Declare line. I used Microsoft's Dependency Walker to discover to what extent the names had been mangled.
• A reference to SCRRUN.DLL was added to the project, making possible the use of the FileSystemObject.
• Bob6 barges past the limit set for the string by VB, so things get a bit unstable. I'm still working through how to pass strings back.

Declare Sub Bob1 Lib "bo_blib.dll" Alias "_Bob1@0" () Declare Function Bob2 Lib "bo_blib.dll" Alias "_Bob2@0" () As Long Declare Function Bob3 Lib "bo_blib.dll" Alias "_Bob3@4" (ByVal i As Long) As Long Declare Sub Bob4 Lib "bo_blib.dll" Alias "_Bob4@4" (ByVal ptr As Long) Declare Function Bob5 Lib "bo_blib.dll" Alias "_Bob5@4" (ByVal ptr As Long) As Long Declare Sub Bob6 Lib "bo_blib.dll" Alias "_Bob6@4" (ByVal ptr As Long) Dim oFSO As New Scripting.FileSystemObject Dim oStream As Scripting.TextStream Sub main() Dim s As String Set oStream = oFSO.OpenTextFile("c:\temp\hua.txt", ForReading, False, TristateTrue) s = oStream.ReadLine oStream.Close Bob1 Debug.Print Bob2 Debug.Print Bob3(21) Bob4 (StrPtr(s)) Debug.Print Bob5(StrPtr(s)) Bob6 StrPtr(s) MsgBox s End Sub

By the way, if you think my code sucks, say so. I'm a total newb when it comes to Ada. Critiques are always welcome. King Solomon said, "The wise person accepts instructions." and also "Better is open rebuke than hidden love."

© Copyright Bruce M. Axtens., 2007

[Protium] Splitting

Here's a short script for splitting a file. The file in this case is the perl language data file from the PLEAC website. pleac_perl.data contains sections marked with "# ^^PLEAC^^_" followed by a number. The section applies until the next section is marked. The script splits each section out of pleac_perl.data into pleac_perl_number.p. I'm working through these files and re-expressing the intent of the perl code in Protium.

<@ DEFAREFLE>pleac</@> <@ DEFFLELIT>pleac|C:\Documents and Settings\All Users\Documents\Projects\PLEAC\pleac_perl.data</@> <@ ITEENUFLELIT>pleac| <@ LETVARELTFLE>aLine|...</@> <@ TSTRXPVARLIT>aLine|# \^\^PLEAC\^\^_(\d+\.\d+)</@> <@ IFF><@ LETVARKEY>number|__Reg1</@> <@ ACTSNKLIT>__Off</@> <@ ACTSNKEMMLIT>pleac_perl_&number;.p</@> </@> <@ SAYVAR>aLine</@> </@>

The code may be described as follows:

1. Define a work area, or alias, for the data file, calling it 'pleac'.
2. Open the text file within that work area, using define-file-lit.
3. Start a loop which iterates through an enumeration of the lines of data in the work area.
4. Let a variable contain the data in the current line of the work area.
5. Test whether the regular expression works for the current line.
6. If it does work, let a variable contain the number found, ...
7. ... turn off any output redirection, ...
8. ... and redirect output to the file 'pleac_perl_' + the number found (in the same directory as the script).
9. End of the if.
10. Output the contents of the line.
11. End of the iteration.

Simple ... and way powerful!

© Copyright Bruce M. Axtens, 2007

[Protium] 'Assert' as a User-Defined Syllable (UDS)

From time to time, during development, it helps to have an assert. That is, a means of checking whether you got the answer you were expecting, but without having to write lots of repetitive code in the process. To that end, therefore, I've come up with a UDS, an user defined syllable, which implements the concept (and demonstrates other Protium functionality as well.)

For the sake of clarity, I've put each syllable, or "opcode", in title case. This is not something that must be done; Protium cares not what case or mix of cases the instructions are in.

<@ DefUdsLitLit>ASR|__Transformer|<@ Sao> lhs=<@ LetVarPar>lhs|1</@> rhs=<@ LetVarPar>rhs|2</@> <@ IffNotExmVarVarLit>lhs|rhs| <@ LetResEkmLit>...|Assertion error: '&lhs;' <> '&rhs;'</@> </@> <@ Ign><@ Els> <@ LetResVar>...|lhs</@> </@></@> </@> </@>

A UDS is 'defined', thus the DEF at the beginning. An UDS has 3 parameters: the syllable itself, then the kind of UDS (more about that later), and then the Protium code which is processed each time the syllable is used. In this case, the syllable is ASR, the type is '__Transformer' and the code starts with <@ SAO> (more about SAO later, too).

Parameters may be passed to UDSes, and retrieved using PAR. In this case, the variable lhs is given the value of the first parameter, and the variable rhs the value of the second.

Next comes the test which forms the basis of an assert: does what is contained in lhs equal what is contained in rhs? The fourth line's opcodes implement this test: if not exact-match variable variable literal, with the arguments lhs, rhs and then another Protium instruction which is only evaluated if the test for exact-match fails.

If lhs does not match rhs, an EKM (Expand Macro Key And Memory) of the literal string "Assertion error: '&lhs;' <> '&rhs;'" is performed. lhs and rhs are bracketed by ampersand and comma, with the result that these symbols are replaced with the values of the variables themselves. The result is stored in the RES (the result) of the UDS, which is handed back to the calling code. Next comes a block wrapped in IGN. This is an artefact from the development of ASR. Code inside an IGN is ignored, that is, not executed. IGNs are predominantly used for documentation but can just as easily be used to isolate parts of the code.

<@ LetVarLit>string|Once a jolly swagman camped by a billabong</@> <@ SayAsrCapLit><@ SayActRmdVarLitLitLit>string|23|6|quatter</@>|Once a jolly squatter camped by a billabong</@> <@ LetVarLit>string|Once a jolly swagman camped by a billabong</@> <@ SayAsrCapLit><@ SayActRmdVarLitLitLit>string|23|6|quatter</@>|all your base are belong to us</@>

Here are two invocations of the ASR syllable. The first generates nothing because the actioned RMD, the reverse-mid, actually does convert "Once a jolly swagman camped by a billabong" into "Once a jolly squatter camped by a billabong". The second invocation gives the error message because there's no way that that reverse-mid is going to be able to produce "all your base are belong to us".

Now SAO, aside from being the name of an Arnott's biscuit, also stands for "Suppress All Output". Usually text outside the <@> and </@> of a Protium instruction is echoed to the relevant transput (read input-output device). SAO suppresses that echoing. This explains why you don't see 'lhs=' and 'rhs=' each time ASR is invoked. SAO also suppresses everything output by SAY.

Regarding __Transformer, every syllable opcode belongs to a particular group of syllables and each group has certain specific behaviours. Other groups include __Modifier, __Alternator, __Evaluator and __Locator. Read the friendly manual.

Finally, a word about testing. It was the developer's original design to separate testing from branching, and it was due to pressure from the Protium user community which forced the merging of the two into the form seen in most other programming languages. According to the original design, the test and branch code should have looked like this:

<@ TstNotExmVarVar>lhs|rhs</@> <@ IffLit> <@ LetResEkmLit>...|Assertion error: '&lhs;' <> '&rhs;'</@> </@>

Both ways of doing it work. I'm starting to come round to the idea that the original design is the better one, especially seeing that Protium supports ternary logic (true, false, unknown). More about that some other time.

This article can also be found at Isotopes of Hydrogen on the Protium Blue Forum.

© Copyright Bruce M. Axtens, 2007

[Protium] Templating

Finally, after much talk, here's some action on the Protium front. This the first posting in the 'Isotopes of Hydrogen' series, on the subject of Templating. IoH is housed at the Protium Blue Forum.

If you don't want to go through the process of forum registration, the article is reproduced below.

---

We're implementing a SOAP interface to Google's AdWords. There are a number of services and subroutines. The following code was developed to speed up the implementation by taking the service and subroutines names and turning them into VB6 subs.

<@ LETVARLIT>template| Sub &Function;(oEnvelope As CoEnvelope, _ oHTTP As HTTPTransport, _ URL As String, _ URI As String, _ Method As String, _ sService As String, _ sMethod As String, _ dDate As Date) Method = "&Function;" URI = ADWORDS_API URL = &Service; oEnvelope.SetMethod Method, URI oEnvelope.Parameters.Create "service", sService oEnvelope.Parameters.Create "method", sMethod oEnvelope.Parameters.Create "date", dDate oHTTP.SOAPAction = Method End Sub</@>

First there's the definition of template. Note that some parts of the template are Visual BASIC and some are something else: an ampersand, a word and a semicolon. These will be replaced with the text in the following list.

<@ LETVARLIT>params|TRAFFIC_ESTIMATOR_SERVICE checkKeywordTraffic estimateAdGroupList estimateCampaignList estimateKeywordList</@>

params contains, as a first item, the name of the service. After it are all the routines germane to that service. I got these by copying and pasting from Google's AdWords API website.

<@ LETCNDLSTVARLIT>L|params| </@>

This bit takes the variable params, and converts it to a list, splitting on newlines. CND means 'construct delimited'. The list is called L (really original, I know.)

<@ ITEENULSTLIT>L| <@ INILIT> <@ DEFMACELTLST>Service|L</@> </@> <@ ONGLIT> <@ DEFMACELTLST>Function|L</@> <@ SAYEKMVAR>template</@> </@> </@>

Next we iterate by enumeration of the L list. Here we see one of the special qualifiers that can be used with iteration, INI, that only fires on the first pass through the iteration and is ignored otherwise. In this case, its 'payload' is to define a macro where Service contains the current (in this case, the first) element of the L list.

ONG means 'ongoing' and fires on the second and subsequent iterations. The payload is in two parts. The first is to define another macro, Function, with the value of the current element of L. The second is to evaluate template, using EKM, substituting &Service; and &Function; with the values stored in the Service and Function macros.

By using INI, Service gets set only once. ONG ensures that Function will never contain the name of the service, and always contain the current name of the function.

An abbreviated sample of the output is below. There are 11 services and over 40 subs in total. Granted, there's still quite a bit of work to make these subs useful, but a lot of the hack work has been done by the computer, which is what it's there for.

Sub checkKeywordTraffic(oEnvelope As CoEnvelope, _ oHTTP As HTTPTransport, _ URL As String, _ URI As String, _ Method As String, _ sService As String, _ sMethod As String, _ dDate As Date) Method = "checkKeywordTraffic" URI = ADWORDS_API URL = TRAFFIC_ESTIMATOR_SERVICE oEnvelope.SetMethod Method, URI oEnvelope.Parameters.Create "service", sService oEnvelope.Parameters.Create "method", sMethod oEnvelope.Parameters.Create "date", dDate oHTTP.SOAPAction = Method End Sub ... Sub estimateKeywordList(oEnvelope As CoEnvelope, _ oHTTP As HTTPTransport, _ URL As String, _ URI As String, _ Method As String, _ sService As String, _ sMethod As String, _ dDate As Date) Method = "estimateKeywordList" URI = ADWORDS_API URL = TRAFFIC_ESTIMATOR_SERVICE oEnvelope.SetMethod Method, URI oEnvelope.Parameters.Create "service", sService oEnvelope.Parameters.Create "method", sMethod oEnvelope.Parameters.Create "date", dDate oHTTP.SOAPAction = Method End Sub

© Copyright Bruce M. Axtens, 2007

[Visual Basic 6] Boost again, but as a binary

As nice as the VBScript version of BOOST is, some people prefer a compiled binary. So, here's the VB6 version.

But first, credit where credit is due:
* Ultimate Packer for eXecutables which compresses binaries;
* Euphoria programming language website for the SETSUBSYS tool which I use to turn a GUI applications into a console ones;
* Experts Exchange for their ParseCommandLineValue function; and
* vb.mvps.org for their sample on how to make console applications

Okay, now to the code. The algorithm is very similar to the VBScript project, but there are some new things.

First the constants:

Option Explicit 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

Here are two functions vital to making the application function appropriately in a command line environment. The first discovers the handle for StdOut. The second writes to a file handle, in this case the handle for StdOut.

After the function declarations is a user-defined wrapper. Interesting how the output of the WriteFile function is transmitted to the return value of the wrapper (the last argument in the call is the name of the wrapper function -- I'd never seen that before.)

'http://vb.mvps.org/samples/project.asp?id=console 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

This is the SetPriority function pulled straight out of the VBScript project. Notice I haven't even been polite enough to VB6 to specify sProcess As String and nPriority As Integer. I haven't typed any of the variables local to the function either. It doesn't matter: VB6 types them all as Variant and takes care of my carelessness (and I have put them in since.)

Function SetPriority(sProcess, nPriority) Dim sComputer Dim oWMIService Dim cProcesses Dim oProcess Dim bDone bDone = False sComputer = "." Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2") Set cProcesses = oWMIService.ExecQuery _ ("Select * from Win32_Process Where Name = '" & sProcess & "'") For Each oProcess In cProcesses oProcess.SetPriority (nPriority) bDone = True Next SetPriority = bDone End Function

Next comes the Experts Exchange code for parsing the command line.

'http://www.experts-exchange.com/Programming/Programming_Languages/Q_20832956.html#9992009 Public Function ParseCommandLineValue(ByVal sCommandLine As String, ByVal sKey As String) As String Dim lPosFrom As Integer Dim lPosLen As Integer Dim sValue As String 'Initialize ParseCommandLineValue = "" If Trim(sKey) = "" Then Err.Raise vbObjectError, "Invalid key" End If 'Get Datasource lPosFrom = InStr(1, sCommandLine, sKey, vbTextCompare) If lPosFrom > 0 Then 'Find the position of the Value after length of the Key lPosFrom = lPosFrom + Len(sKey) 'Get value sValue = Mid(sCommandLine, lPosFrom) 'till end 'Find where next value starts lPosLen = InStr(lPosFrom, sCommandLine, "/") If lPosLen > 0 Then 'last value of the command line lPosLen = lPosLen - lPosFrom Else 'more values after this one lPosLen = Len(sValue) End If 'Return sValue = Mid(sCommandLine, lPosFrom, lPosLen) ParseCommandLineValue = sValue End If End Function

Now the Main. For ease of access to the relevant values for the SetPriority function, I've used a Collection. I could have used VBScript's Dictionary (by adding a reference to SCRRUN.DLL in the Projects menu) but the Collection works well enough.

Sub Main() 'http://vb.mvps.org/samples/project.asp?id=console Dim sLevel As String Dim nLevel As Integer Dim sProcess As String Dim sCommand As String Dim cPriorities As New Collection cPriorities.Add LOW_PRIORITY, "1" cPriorities.Add BELOWNORMAL_PRIORITY, "2" cPriorities.Add NORMAL_PRIORITY, "3" cPriorities.Add ABOVENORMAL_PRIORITY, "4" cPriorities.Add HIGH_PRIORITY, "5" cPriorities.Add REALTIME_PRIORITY, "6"

Now we parse the commandline and output a message about syntax if things aren't correctly specified there.

sCommand = Command() sProcess = Trim(ParseCommandLineValue(sCommand, "/process:")) sLevel = Trim(ParseCommandLineValue(sCommand, "/level:")) If sProcess = "" Or sLevel = "" Then ConsoleWrite ("Syntax:" & vbNewLine & _ vbTab & "Boost /process:{processname} /level:{runlevel}" & vbNewLine & _ "Run levels:" & 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) End End If

Assuming that the commandline is okay, we then attempt to figure out the runlevel value from the user-supplied specification, and show an appropriate error if it doesn't make sense.

On Error Resume Next nLevel = cPriorities.Item(sLevel) If Err.Number = 5 Then ConsoleWrite ("Invalid selection of runlevel.") End End If On Error GoTo 0

And, finally, where it is all made to happen. If everything's set up right and there is in fact a process running that matches what's stored in sProcess, then it gets boosted and the user is informed. If there's no match, the message says that the process wasn't boosted.

ConsoleWrite (sProcess & IIF(SetPriority(sProcess, nLevel), _ " boosted", " not boosted") & " to priority " & sLevel & _ " (" & nLevel & ").") End Sub

Having compiled the code to an .EXE, I used the setsubsys tool to change the binary from a GUI app to a console app

setsubsys boost.exe /C

I also compressed it using UPX,

upx -9 boost.exe

taking a 24576 byte application and leaving me with an 8192 byte one.

If anyone's interested in downloading the BOOST binary (which now contains a KILL_PROCESS 'level'), please leave a comment to that effect and I'll put up a download link.

By the way, if you think my code sucks, say so. Critiques are always welcome. King Solomon said, "The wise person accepts instructions." and also "Better is open rebuke than hidden love."

[VBScript] Boost - changing process priority using WMI

I have little sh script on my iBook which changes the priority of a given process so that the OS services it more frequently, giving the impression of faster execution. Below is a re-implementation in VBScript of a similar tool for Windows. First a few constants and the arrays that handle the commandline options.

Option Explicit 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 Dim aNames Dim aValues aNames = Array( "LOW", "BELOWNORMAL", "NORMAL", "ABOVENORMAL", "HIGH", "REALTIME" ) aValues = Array( LOW_PRIORITY, BELOWNORMAL_PRIORITY, NORMAL_PRIORITY, ABOVENORMAL_PRIORITY, HIGH_PRIORITY, REALTIME_PRIORITY )

Next, the real meat of this tool: the Windows Management Interface (WMI) call which takes a string and a numeric defining the process name and the priority level.

Function SetPriority( sProcess, nPriority ) Dim sComputer Dim oWMIService Dim cProcesses Dim oProcess Dim bDone bDone = False sComputer = "." Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2") Set cProcesses = oWMIService.ExecQuery _ ("Select * from Win32_Process Where Name = '" & sProcess & "'") For Each oProcess in cProcesses oProcess.SetPriority( nPriority ) bDone = True Next SetPriority = bDone End Function

Next a few less inspiring routines: IIF (available in VB but not in VBScript), ArrayOffset, and HelpText.

Function IIF( bCondition, vTrue, vFalse ) Dim vResult If bCondition = True Then vResult = vTrue Else vResult = vFalse End If IIF = vResult End Function Function ArrayOffset( sItem, aList ) Dim i Dim u Dim nResult nResult = -1 For i = 0 To UBound( aList ) If sItem = aList( i ) Then nResult = i Exit For End If Next ArrayOffset = nResult End Function Sub HelpText WScript.Echo "Syntax:" WScript.Echo vbTab & "Boost {appName} /L:{priority}" WScript.Echo vbTab & "priority: LOW | BELOWNORMAL | NORMAL | ABOVENORMAL | HIGH | REALTIME" WScript.Echo WScript.Echo vbTab & "E.g. boost cscript.exe /l:realtime" End Sub

Finally the main routine, which uses Named and Unnamed Arguments to handle command line parameters. The name of the process is pulled out of the command line using an Unnamed Argument, and the text representation of the priority is pulled out using a Named Argument ("L"). If the priority is acceptable the name and priority are passed to the SetPriority routine.

If WScript.Arguments.Unnamed.Count = 0 Or WScript.Arguments.Named.Count = 0 Then HelpText WScript.Quit End If Dim sApp, sPrio, nOffs sApp = WScript.Arguments( 0 ) sPrio = WScript.Arguments.Named.Item("L") nOffs = ArrayOffset( UCase( sPrio ), aNames ) If nOffs = -1 Then WScript.Echo "The",sPrio,"priority cannot be assigned to",sApp HelpText Else WScript.Echo sApp, _ IIF( SetPriority( sApp, aValues( nOffs ) ), _ "boosted to " & aNames( nOffs ) & " priority", _ "not boosted" ) End If

A further refinement of this tool might be to provide for one other possibility for /L: 'KILL' or 'TERMINATE'. By way of comparison here's the original sh script.

#!/bin/sh ps axxw | grep $1 | grep -v grep | grep -v boost sudo renice -20 `ps axww | grep $1 | grep -v grep | grep -v boost | awk '{print $1}'`