Metamorphing Machine I rather be this walking metamorphosis
than having that old formed opinion about everything!

Let's build a transpiler! Part 51

This is the fifty-first post in a series of building a transpiler.
You can find the previous ones here.

Quiz

If Condition1 Then
If Condition2 Then Debug.Print "Huey"
ElseIf Condition3 Then Debug.Print "Louie"
Else
Debug.Print "Dewey"
End If

If Condition1 is False, Condition2 is True, and Condition3 is True, what will be printed in Debug window?


Louie.
The indentation is wrong. It should be:

If Condition1 Then
If Condition2 Then Debug.Print "Huey"
ElseIf Condition3 Then Debug.Print "Louie"
Else
Debug.Print "Dewey"
End If



After an Optional parameter usually there can only be another Optional parameter.
What is the only situation where there can be a non-optional parameter after an optional one?


In a Property Let or Set.
Example:

Public Property Let Abc(A As Integer, Optional B As String, C As Boolean)
Use:

obj.Abc(1) = True '<-C will be True



In VB.NET, what is the only situation where the code below will not result in an exception being raised?

Dim obj As MyObject = Nothing
Dim x = obj.SomeMethod()


When SomeMethod is an extension method.

Example:

Module Example
<Extension>
Public Function SomeMethod(ByVal This As MyObject) As UInteger
If This Is Nothing Then Return 0
(...)
End Function
End Module



In VB.NET, usually is not possible to Return inside a function without providing a value to be returned.
What is the only situation where it can happen?


When the function is an Iterator one. In this context, Return breaks the iteration.



Suppose the code below is inside a module:

Option Explicit

Public Sub Main()
Debug.Print ToBe Or Not ToBe
End Sub

It does not compile. What is the minimum change needed to make it compile and print True in the Debug window?


Option Explicit

Public Sub Main()
Dim ToBe As Boolean

Debug.Print ToBe Or Not ToBe
End Sub



Suppose the code below is inside a module:

Option Explicit

Public Sub Main()
Dim ToBe As Boolean

Debug.Print ToBe Or Not ToBe
Debug.Print That Is TheQuestion
End Sub

It does not compile. What is the minimum change needed to make it compile and print True twice in the Debug window?


Option Explicit

Public Sub Main()
Dim ToBe As Boolean
Dim That, TheQuestion As Object

Set That = TheQuestion

Debug.Print ToBe Or Not ToBe
Debug.Print That Is TheQuestion
End Sub

Rem: A better approach would be to declare That as being an Object too, but it would not be the minimum change.



Is it possible to download a 5MB external hard drive?


Yes. :)

A 50's era big hard-drive being downloaded from an airplane.

Back to business

So, last time I said I would try to go back transpiling for real.
In preparing to do that, I gave a deep look into IDispatch interface. That is the one that will allow us to have things like TypeName and CallByName. It has four methods: OK, don't panic. Let's check that ITypeInfo thing.
It has 19 methods. Oh, Gawd. Ninee. Teen. Methods! WTF?
There must be a way to implement them in a timely fashion, right?
It turns out, it has. Actually, four ways.

Everything you never wanted to know about ITypeInfo implementation, but I'll tell you anyway

First, you can implement them one by one.
I think this would allow us to use them in OSes other than Windows, but I'm not sure.
And it would take a lot of time to have them working.

Or you can use CreateDispTypeInfo, from OleAut32.dll. You give it an INTERFACEDATA structure and it builds an ITypeInfo instance for you.
INTERFACEDATA depends on METHODDATA, which in its turn depends on PARAMDATA.
Obviously, it cannot be used outside of Windows' borders as, say, Linux does not have an OleAut32.dll available...

Well, maybe I can start with CreateDispTypeInfo and later implement it all myself?
The thing is, the returned ITypoInfo does not know a thing about optional parameters. It does not know about Help information either, which may be needed by TypeName.
The page linked above even suggests using LoadTypeLib and GetTypeInfoOfGuid functions instead.

LoadTypeLib gets a typelib path and returns an ITypeLib instance. Fair enough.
ITypeLib has a GetTypeInfoOfGuid function that gets a reference to a GUID and returns our ITypeInfo. Fair enough again.
To have a typelib, one needs to have a file written in MIDL language and compile it through MkTypLib.exe or MIDL.exe.
I searched high and low but could not find any typelib compiler apart from this two. So, still stuck to Windows land.

Another option is to use the CreateTypeLib function. You provide a flag and a path, and it returns an implementation of an ICreateTypeLib interface.
From there, the only way is down a rabbit hole of two more interfaces (ICreateTypeInfo, and ITypeInfo), five enums, and ten additional structures. Phew!

If you followed all those links above, you may have noticed that we are dealing with a lot of C interfaces.
We would need to translate a whole shebang of C interfaces into something VB-readable.
Again, I searched for automatic translators from C to VB6, and again, came empty-handed.
So, I've built my own!

What you're about to see cannot be uncee. Or can it?

I call it uncee because it "undoes" C. It is a quick script, not that sophisticated, but it helps a lot.
You can copy the code below, paste it inside an uncee.vbs file, and drop a .TXT file onto it.
It will output a .UNCEED file with the definitions translated to VB6.

Option Explicit

'Limitations:
' It errors out on arrays' square brackets containing subscripts, like UINT x[9].
' It gets [Type]s' and [Enum]s' names from "tag" position, not from "bottom" position.
' It only ouputs [Public].
' It does not handle comments (// or /*...*/) inside [struct]s or [enum]s.
' It discards some (most?) attributes, but stumble upon some of them.
' It does not handle expressions in [enum]s' values.
' VB does not have [union]s, so we output them commented out.

'Wish-list:
' Allow user to specify whether to use [Public] or [Private].
' Allow user to specify whether to output [PtrSafe] or not.

'Tips:
' * Add "[]" to arrays' declarations like "BSTR *names"
' * Remove "tag" from [enum]s and [type]s names.
' * Use the [Enum] below to suport [LongPtr]s in VB6:
'     Public Enum LongPtr
'         Zero
'     End Enum

Dim Source_, Dest_, DataTypes_, AnonCount_
Call Main()

Sub LoadNamesAndByRefs()
Set DataTypes_ = CreateObject("Scripting.Dictionary")

AddData "ATOM", "Integer", False
AddData "BOOL", "Long", False
AddData "BSTR", "String", False
AddData "BYTE", "Byte", False
AddData "CHAR", "Byte", False
AddData "DISPID", "Long", False
AddData "DWORD", "Long", False
AddData "HDC", "Long", False
AddData "HMENU", "Long", False
AddData "HREFTYPE", "Long", False
AddData "HRESULT", "Long", False
AddData "HWND", "Long", False
AddData "INT", "Long", False
AddData "LCID", "Long", False
AddData "LONG", "Long", False
AddData "LPARAM", "Long", True
AddData "LPCSTR", "String", False
AddData "LPDWORD", "Long", True
AddData "LPINT", "Long", True
AddData "LPOLESTR", "String", False
AddData "LPCOLESTR", "String", False
AddData "LPRECT", "RECT", True
AddData "LPSTR", "String", False
AddData "LPUINT", "Long", True
AddData "LPVOID", "Any", True
AddData "LPWORD", "Integer", True
AddData "LRESULT", "Long", False
AddData "MEMBERID", "Long", False
AddData "PVOID", "Any", True
AddData "REFIID", "Guid", True
AddData "SCODE", "Long", False
AddData "SHORT", "Integer", False
AddData "UINT", "Long", False
AddData "ULONG", "Long", False
AddData "ULONG_PTR", "LongPtr", False
AddData "USHORT", "Integer", False
AddData "VARIANT", "Variant", False
AddData "WORD", "Integer", False
AddData "WPARAM", "Long", False
End Sub

Class CharReader
Private Index_
Private Text_
Private Line_
Private CurrColumn_
Private PrevColumn_
Private LastChar_
Private CanUnread_
Private Length_

Public Sub OpenFile(Path)
Dim File: Set File = CreateObject("Scripting.FileSystemObject").OpenTextFile(Path)
Text_ = File.ReadAll
File.Close

Text_ = Replace(Text_, vbCrLf, vbLf)
Text_ = Replace(Text_, vbCr, vbLf)
Text_ = Replace(Text_, vbTab, " ")
Length_ = Len(Text_)
Line_ = 1
CurrColumn_ = 1
Index_ = 0
CanUnread_ = False
End Sub

Public Function Read
CanUnread_ = True
Index_ = Index_ + 1
LastChar_ = Mid(Text_, Index_, 1)

If Index_ <= Length_ Then
If LastChar_ = vbLf Then
Line_ = Line_ + 1
PrevColumn_ = CurrColumn_
CurrColumn_ = 1
Else
CurrColumn_ = CurrColumn_ + 1
End If
End If

Read = LastChar_
End Function

Public Sub Unread
If Not CanUnread_ Then Abend "Char.ReaderUnread", "Read beyond BOF"
CanUnread_ = False
Index_ = Index_ - 1

If LastChar_ = vbLf Then
Line_ = Line_ - 1
CurrColumn_ = PrevColumn_
End If

LastChar_ = Mid(Text_, Index_, 1)
End Sub

Public Property Get Line
Line = Line_
End Property

Public Property Get Column
Column = CurrColumn_
End Property
End Class

Sub Main()
Dim Ch, Name

If WScript.Arguments.Count = 0 Then
MsgBox "Use: " & WScript.ScriptName & " P:/ath/to/file", vbInformation
WScript.Quit
End If

AnonCount_ = 0
LoadNamesAndByRefs

Dim File: File = WScript.Arguments(0)
Set Source_ = New CharReader
Source_.OpenFile File

With CreateObject("Scripting.FileSystemObject")
Set Dest_ = .CreateTextFile(File & ".unceed")
End With

Do
Ch = Source_.Read

Select Case Ch
Case ""
Exit Do

Case vbLf, " ", ";"
Rem Ignore

Case "["
DiscardAttr

Case "/"
Ch = Source_.Read

Select Case Ch
Case "*"
DiscardBlock

Case "/"
DiscardLine

Case Else
Source_.Unread
Abend "Main", "Unexpected: '/'"
End Select

Case Else
If Not IsA_Z(Ch) And Ch <> "_" Then Abend "Main", "Found: '" & Ch & "'"
Name = GetId(Ch)

Select Case Name
Case "typedef"
Rem Ignore

Case "struct"
ParseStruct

Case "const"
ParseConst

Case "enum"
ParseEnum

Case "union"
ParseUnion

Case Else
ParseFunction Name
End Select
End Select
Loop

Dest_.Close
End Sub

Sub ParseStruct()
ParseTypeOrUnion False
End Sub

Sub ParseUnion()
ParseTypeOrUnion True
End Sub

Sub ParseTypeOrUnion(ByVal IsUnion)
Dim Comment: Comment = ""
Dim Element: Element = "Type"

If IsUnion Then
Comment = "'"
Element = "Union"
End If

Dim Ch: Ch = NextChar
Dim Name: Name = ""

If Ch = "{" Then
AnonCount_ = AnonCount_ + 1
Name = "Anonymous" & AnonCount_
Else
Name = GetId(Ch)
End If

DiscardLine
If IsUnion Then Dest_.Write Comment Else Dest_.Write "Public "
Dest_.WriteLine Element & " " & Name

Do
Dim DataType: DataType = NextChar

Select Case DataType
Case "}"
DiscardLine
Exit Do

Case "["
DiscardAttr
DataType = NextChar
End Select

DataType = GetId(DataType)

If DataType = "union" Then
ParseUnion

Ch = Source_.Read

If IsA_Z(Ch) Or Ch = "_" Then
DataType = GetId(Ch)

ElseIf Ch = "}" Then
DiscardLine
Exit Do

Else
DataType = FindId
End If
End If

Dim StarCount: StarCount = CountStars
If StarCount <> 0 Then DataType = "LongPtr"

Dim Member: Member = FindId
Dim IsCArray: IsCArray = False

Ch = Source_.Read
If Ch = "[" Then
Ch = Source_.Read

If Ch = "]" Then
IsCArray = True
Else
Source_.Unread
Source_.Unread
End If
Else
Source_.Unread
End If

DiscardLine
Dest_.Write Comment & vbTab
PrintDataType IsCArray, vbUseDefault, Member, DataType
Dest_.WriteLine
Loop

Dest_.WriteLine Comment & "End " & Element
Dest_.WriteLine
End Sub

Sub ParseConst()
Dim DataType: DataType = FindId
Dim Name: Name = FindId
Dim Ch: Ch = NextChar
If Ch <> "=" Then Abend "ParseConst", "Expected: '='"
Dim Value: Value = NextChar

If IsA_Z(Value) Then
Value = GetId(Value)

ElseIf Is0_9(Value) Or Value = "-" Then
Value = GetNumber(Value)

Else
Abend "ParseConst", "Invalid const value"
End If

Dest_.Write "Public Const "
PrintDataType , vbUseDefault, Name, DataType
Dest_.WriteLine " = " & Value
End Sub

Sub ParseEnum()
Dim Name: Name = FindId
DiscardLine
Dest_.WriteLine "Public Enum " & Name
Dim Done: Done = False

Do
Dim Member: Member = NextChar
If Member = "}" Then Exit Do

Member = GetId(Member)
Dim Value: Value = NextChar

Select Case Value
Case "="
Value = GetNumber(NextChar)
Value = " = " & Value

Case ",", vbLf
Value = ""

Case "}"
Value = ""
Done = True

Case Else
If AscW(Value) < 32 Then Value = "char " & AscW(Value) Else Value = "'" & Value & "'"
Abend "ParseEnum", "Unexpected: " & Value
End Select

Dest_.WriteLine vbTab & Member & Value
Loop Until Done

Do
Dim Ch: Ch = Source_.Read
Loop Until Ch = ";"

DiscardLine
Dest_.WriteLine "End Enum"
Dest_.WriteLine
End Sub

Sub ParseFunction(ByVal RetVal)
Dim StarCount: StarCount = CountStars
If StarCount <> 0 Then RetVal = "LongPtr"

Dim Name: Name = FindId
Dim Ch: Ch = NextChar
If Ch <> "(" Then Ch = NextChar
If Ch <> "(" Then Abend "ParseFunction", "Expected: '('; Got: '" & Ch & "'" & Name

Dest_.Write "Public Declare "
If RetVal = "void" Then Dest_.Write "Sub " Else Dest_.Write "Function "
Dest_.Write Name
Dest_.Write " Lib ""<?>"" ("
Dim Count: Count = 0

Do
Count = Count + 1
If Count > 1 Then Dest_.Write ", "

Dim ArgType: ArgType = NextChar
If ArgType = ")" Then Exit Do
ArgType = GetId(ArgType)

StarCount = CountStars
Dim ArgName: ArgName = FindId
Ch = NextChar
Dim IsCArray: IsCArray = False

If Ch = "[" Then
Ch = NextChar

If Ch = "]" Then
IsCArray = True
If StarCount = 0 Then StarCount = 1
Ch = NextChar
Else
Ch = "["
End If
End If

Dim Protocol

Select Case StarCount
Case 0
Protocol = vbFalse 'ByVal

Case 1
Protocol = vbTrue 'ByRef

Case 2
Protocol = vbTrue 'ByRef
ArgType = "LongPtr"

Case Else
Protocol = vbFalse 'ByVal
ArgType = "LongPtr"
End Select

PrintDataType IsCArray, Protocol, ArgName, ArgType
Loop While Ch = ","

DiscardLine
Dest_.Write ")"
If RetVal <> "void" Then PrintDataType , vbUseDefault, "", RetVal
Dest_.WriteLine
Dest_.WriteLine
End Sub

Function CountStars()
CountStars = 0

Do
Dim Ch: Ch = Source_.Read

Select Case Ch
Case vbLf, " "
Rem Ignore

Case "*"
CountStars = CountStars + 1

Case Else
Source_.Unread
Exit Do
End Select
Loop
End Function

Function GetId(ByVal Ch)
GetId = Ch

Do
Ch = Source_.Read
Dim IsIdChar: IsIdChar = IsA_Z(Ch) Or Is0_9(Ch) Or Ch = "_"

If Not IsIdChar Then
Source_.Unread
Exit Do
End If

GetId = GetId & Ch
Loop
End Function

Function GetNumber(ByVal Ch)
GetNumber = Ch

Do
Ch = Source_.Read
If Ch = "" Then Exit Do

Ch = LCase(Ch)
If Not Is0_9(Ch) And Ch <> "x" Then Exit Do
GetNumber = GetNumber & Ch
Loop

Dim IsHex: IsHex = Left(GetNumber, 2) = "0x"
If IsHex Then GetNumber = Mid(GetNumber, 3)

While Left(GetNumber, 1) = "0"
GetNumber = Mid(GetNumber, 2)
Wend

If GetNumber = "" Then GetNumber = "0"
If InStr(GetNumber, "x") Then Abend "GetNumber", "Invalid number"
If IsHex And (Len(GetNumber) > 1 Or Not Is0_9(GetNumber)) Then GetNumber = "&H" & GetNumber
End Function

Function NextChar()
Do
NextChar = Source_.Read

Select Case NextChar
Case vbLf, " "
Rem Ignore

Case Else
Exit Function
End Select
Loop
End Function

Function FindId()
Do
Dim Ch: Ch = NextChar
If Ch = "" Then Exit Do

If IsA_Z(Ch) Or Ch = "_" Then
FindId = GetId(Ch)
Exit Function
End If
Loop
End Function

Function IsA_Z(ByVal Ch)
IsA_Z = Ch >= "a" And Ch <= "z" Or Ch >= "A" And Ch <= "Z"
End Function

Function Is0_9(ByVal Ch)
Is0_9 = Ch >= "0" And Ch <= "9"
End Function

Sub DiscardLine()
Do
Dim Ch: Ch = Source_.Read
Loop Until Ch = vbLf
End Sub

Sub DiscardBlock()
Do
Dim Ch: Ch = Source_.Read

Select Case Ch
Case ""
Exit Do

Case "*"
Ch = Source_.Read
If Ch = "" Then Exit Do
If Ch = "/" Then Exit Sub
End Select
Loop

Abend "DiscardBlock", "Unclosed comment block"
End Sub

Sub DiscardAttr()
Do
Dim Ch: Ch = Source_.Read
If Ch = "" Then Exit Do
If Ch = "]" Then Exit Sub
Loop

Abend "DiscardAttr", "Unclosed attribute"
End Sub

Sub Abend(ByVal Origin, ByVal Msg)
Err.Raise vbObjectError + 666, Origin, Msg & vbNewLine & vbTab & "at line " & Source_.Line
End Sub

Class NameAndByRef
Public Name
Public IsByRef
End Class

Sub AddData(ByVal CName, ByVal VbName, ByVal IsByRef)
Dim Obj: Set Obj = New NameAndByRef
Obj.Name = VbName
Obj.IsByRef = IsByRef
DataTypes_.Add CName, Obj
End Sub

Sub PrintDataType(ByVal IsCArray, ByVal Protocol, ByVal Name, ByVal DataType)
If VarType(IsCArray) = vbError Then IsCArray = False

If DataTypes_.Exists(DataType) Then
Dim DT: Set DT = DataTypes_(DataType)
DataType = DT.Name

Select Case Protocol
Case vbTrue
If DT.IsByRef Then
Protocol = vbFalse
DataType = "LongPtr"
End If

Case vbFalse
Protocol = DT.IsByRef
End Select
End If

If Protocol = vbTrue And DataType = "String" Then Protocol = vbFalse
If IsCArray And Protocol <> vbUseDefaultThen Protocol = vbTrue

Select Case Protocol
Case vbTrue
Dest_.Write "ByRef "

Case vbFalse
Dest_.Write "ByVal "
End Select

Dest_.Write Name
If IsCArray Then Dest_.Write "()"
Dest_.Write " As "
Dest_.Write DataType
End Sub

Or you can use it online:





And that, my friends, is how I dodged diving into transpiling one more time...
Next week I'll give it a try once more. I'm still figuring out what my next step will be.

Andrej Biasic
2021-09-15