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

Let's build a transpiler! Part 23

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

Since the last time we worked on our transpiler, it has gone through significant changes.
I'm going to walk you through what happened:

First, I wanted to collect all error messages - at least Parser's error messages - in one single place.
So that's what I did. I created a Messages module and cut/pasted Parser's error messages there.
Each message now has the creative name of Msg001, Msg002, and so on. Maybe in the future, I'll change it to something more meaningful.

Why did I do that you may ask? Because if we ever want to change messages' language, we could. We would need a language file to read from, write a little code to do that, and maybe change the Messages module into a class.
No rocket science at all.

Second, I don't like having magical numbers throughout my code. There are a few of them there and they bug me every time one captures my eye.
That's why the Globals module came to life and its function SizeOf. (I intend to transform it in a true macro in the future, but for now, it has to be the way it is now.)
It receives a VbVarType enumerand and returns its data type's counterpart size. For now, I'm only using it to Integer, though, and not dealing with Strings, UDTs, or Objects at all.
You will notice I've put an If directive there, so it can be used even when we'd have a 64-bit environment.
Surprisingly - at least for me - Win32 conditional compiler constant is True inside Visual Basic 6.0's IDE.

Moving on, I've fixed two shortcomings (there's a third one I've not dealt with yet.)
When parsing a Const, it can be a fixed-length string, like "Const Foo As String * 3 = "Foo".
We had no way to capture it, that's why I've created a DataType class.
It had a Name property to receive the data type name's Token and also has a FixedLength property to account for those scenarios.

Having a proper class to store data type's attributes allowed me to insert a third property there, IsArray, so we can keep this information where it belongs and get rid of DeclareConstruct's ReturnsArray property, for instance.

DataType is used in ConstConstruct, DeclareConstruct, and Parameter classes and FromChar function.

I said "had a Name property" because I renamed it to Id. I did it to fix the second shortcoming: There are some circumstances where we have a compound data type name. It is comprised of its project's name, followed by a dot, followed by the data type name itself.
Like "Dim Dic As Scripting.Dictionary".
The problem is our Name properties can have only a single Token and we need two.

Having that in mind, I've created an Identifier class that has two Token properties: Project and Name. Even though we can only have Projects in DeclareConstruct, Parameter, EventConstruct, and in the coming SubConstruct, FunctionConstruct, and PropertyConstruct classes, I've changed every "Name As Token" property to "Id As Identifier" for consistency's sake.

Then I did the most radical change so far.

We can have a token classified as a keyword, but to know which keyword is there, we'd need to compare its Text property against another string.
It's a wasteful operation, so I committed a premature optimization sin and added a "Code As Long" property to the Token class.
Then I've Privated a Keywords_ variable in Parser and loaded it with all keywords.

While we are parsing an identifier, we go see if it is a keyword by checking Keywords_. If we find is there, we'll assign Code with keyword's index.
How do we get this index from a KeyedList you ask? Creating an IndexOf property, of course!
The next logical step is to have a KeywordConstants enum with the correct index for every keyword.
Now, checking if a token is, say, the As keyword is as simple as comparing its Code property against a kwAs constant.

But I did not stop at keywords. Oh, sir and ma'ams, no, I didn't. I did the same thing for operators and contextual keywords.
(And added a ReadOnly property to KeyedList, because, why not?)
This change spread to several places, so take a look at how it affects Entity, ConstConstruct, EnumConstruct, EnumerandConstruct, DeclareConstruct, Parameter, EventConstruct, and DefType.

As keyword, operator, and identifier tokens do not have Texts anymore - their Code "points" to their strings in Keywords_, Operators_, Contextuals_, or Ids_ dictionaries -, we don't need Normalize anymore.
But if we ever need to retrieve that text from the dictionaries - and for sure we need - we have Parser's NameOf function now to take care of it for us.

Now, enjoy the transpiler's whole source code as it stands at this point.

Next week we'll parse Implements and variable declarations.

Andrej Biasic
2021-01-27

Public Module ForwardCompatibility
Option Explicit

Public Const vbLongLong = 20
Public Const vbLongPtr = 37

Public Enum LongPtr
Zero
End Enum
End Module

Private Module Messages
Option Explicit

Public Property Get Msg001() As String
Msg001 = "Public, Private, Class, or Module"
End Property

Public Property Get Msg002() As String
Msg002 = "Class or Module"
End Property

Public Property Get Msg003() As String
Msg003 = "identifier"
End Property

Public Property Get Msg004() As String
Msg004 = "Rule: End (Class | Module) line_break"
End Property

Public Property Get Msg005() As String
Msg005 = "Rule: vbCr | vbLf | vbCrLf | : | '"
End Property

Public Property Get Msg006() As String
Msg006 = "Ambiguous name detected: "
End Property

Public Property Get Msg007() As String
Msg007 = "Rule: [Public | Private] (Class | Module) identifier line_break"
End Property

Public Property Get Msg008() As String
Msg008 = "Rule: [Public | Private] identifier"
End Property

Public Property Get Msg009() As String
Msg009 = "(Public | Private) identifier"
End Property

Public Property Get Msg010() As String
Msg010 = "Duplicate Option statement"
End Property

Public Property Get Msg011() As String
Msg011 = "Rule: Option Base (0 | 1)"
End Property

Public Property Get Msg012() As String
Msg012 = "[Public] Event identifier [([parms])] line_break"
End Property

Public Property Get Msg013() As String
Msg013 = "Rule: Option Compare (Binary | Text)"
End Property

Public Property Get Msg014() As String
Msg014 = "Binary or Text"
End Property

Public Property Get Msg015() As String
Msg015 = "Rule: Option (Base | Compare | Explicit)"
End Property

Public Property Get Msg016() As String
Msg016 = "Only valid inside Class"
End Property

Public Property Get Msg017() As String
Msg017 = "Event can only be Public"
End Property

Public Property Get Msg018() As String
Msg018 = "Expected: Option or Deftype or Public or Private or Const or Enum or Declare or Type"
End Property

Public Property Get Msg019() As String
Msg019 = "Rule: DefType first[-last] [, ...] line_break"
End Property

Public Property Get Msg020() As String
Msg020 = "first"
End Property

Public Property Get Msg021() As String
Msg021 = "last"
End Property

Public Property Get Msg022() As String
Msg022 = "Duplicate Deftype statement"
End Property

Public Property Get Msg023() As String
Msg023 = "Rule: [Public | Private] Const identifier [As data_type] = expression (list_separator | line_break)"
End Property

Public Property Get Msg024() As String
Msg024 = "Identifier already has a type-declaration character"
End Property

Public Property Get Msg025() As String
Msg025 = "data type"
End Property

Public Property Get Msg026() As String
Msg026 = "Fixed-length allowed only for String"
End Property

Public Property Get Msg027() As String
Msg027 = "list separator or line break"
End Property

Public Property Get Msg028() As String
Msg028 = "Rule: [Public | Private] Enum identifier line_break"
End Property

Public Property Get Msg029() As String
Msg029 = "Enum cannot have a type-declaration character"
End Property

Public Property Get Msg030() As String
Msg030 = "Rule: [Public | Private] Enum identifier line_break"
End Property

Public Property Get Msg031() As String
Msg031 = "line break"
End Property

Public Property Get Msg032() As String
Msg032 = "Rule: identifier [= expression] line_break"
End Property

Public Property Get Msg033() As String
Msg033 = "Enum member cannot have a type-declaration character"
End Property

Public Property Get Msg034() As String
Msg034 = "Rule: End Enum"
End Property

Public Property Get Msg035() As String
Msg035 = "Enum without members is not allowed"
End Property

Public Property Get Msg036() As String
Msg036 = "Rule: [Public | Private] Declare (Sub | Function) identifier [CDecl] " & _
"Lib lib_string [Alias alias_string] ([parms]) [As data_type[()]]"
End Property

Public Property Get Msg037() As String
Msg037 = "Sub or Function"
End Property

Public Property Get Msg038() As String
Msg038 = "lib string"
End Property

Public Property Get Msg039() As String
Msg039 = "alias string"
End Property

Public Property Get Msg040() As String
Msg040 = "Duplicated declaration in current scope"
End Property

Public Property Get Msg041() As String
Msg041 = "Rule: [[Optional] (ByVal | ByRef) | ParamArray] identifier[type_declaration_char][()] " & _
"[As data_type] [:= expression]"
End Property

Public Property Get Msg042() As String
Msg042 = "Too many formal parameters"
End Property

Public Property Get Msg043() As String
Msg043 = "Cannot have both Optional and ParamArray parameters"
End Property

Public Property Get Msg044() As String
Msg044 = "Optional not allowed"
End Property

Public Property Get Msg045() As String
Msg045 = "ParamArray not allowed"
End Property

Public Property Get Msg046() As String
Msg046 = "ByVal not allowed"
End Property

Public Property Get Msg047() As String
Msg047 = "ByRef not allowed"
End Property

Public Property Get Msg048() As String
Msg048 = "ParamArray parameter must be an array"
End Property

Public Property Get Msg049() As String
Msg049 = "Identifier already has a type-declaration character"
End Property

Public Property Get Msg050() As String
Msg050 = "As [project_name.]identifier"
End Property

Public Property Get Msg051() As String
Msg051 = "ParamArray must be an array of Variants"
End Property

Public Property Get Msg052() As String
Msg052 = "Sub, Property Let, or Property Get cannot have an As clause"
End Property

Public Property Get Msg053() As String
Msg053 = "Parameter is not Optional"
End Property

Public Property Get Msg054() As String
Msg054 = "ParamArray cannot have a default value"
End Property

Public Property Get Msg055() As String
Msg055 = "Property Let/Set should have at least one parameter"
End Property

Public Property Get Msg056() As String
Msg056 = "Property Let/Set should have at least one non-optional parameter"
End Property

Public Property Get Msg057() As String
Msg057 = "Unclosed parenthesis"
End Property
End Module

Private Module Globals
Option Explicit

Public Function SizeOf(ByVal VariableType As VbVarType) As Integer
Select Case VariableType
Case vbBoolean, vbInteger
SizeOf = 2

Case vbByte
SizeOf = 1

Case vbLong, vbSingle
SizeOf = 4

Case vbLongLong, vbCurrency, vbDouble, vbDate
SizeOf = 8

Case vbDecimal
SizeOf = 16

Case vbLongPtr
#If Win32 Then
SizeOf = 4
#Else
SizeOf = 8
#End If

Case vbVariant
#If Win32 Then
SizeOf = 16
#Else
SizeOf = 24
#End If

Case Else
Debug.Assert False
End Select
End Function

Public Function NewId(ByVal Token As Token) As Identifier
Dim Result As Identifier

Set Result = New Identifier
Set Result.Name = Token
Set NewId = Result
End Function

Public Function NewDataType(ByVal Token As Token) As DataType
Dim Result As DataType

Set Result = New DataType
Set Result.Id = NewId(Token)
Set NewDataType = Result
End Function
End Module

Private Module StringCentral
Option Explicit

Private Const NO_OF_COLS = 5

Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(ByVal Dest As Long, ByVal Src As Long, ByVal Length As Long) As Long

Private CodePoints_() As Integer
Private IsInit_ As Boolean

Private Sub Init()
Dim Bytes() As Byte
Dim Size As Long

IsInit_ = True
Bytes = LoadResData(101, "CUSTOM")
Size = UBound(Bytes) + 1
ReDim CodePoints_(0 To Size \ SizeOf(vbInteger) - 1) As Integer
CopyMemory VarPtr(CodePoints_(0)), VarPtr(Bytes(0)), Size
End Sub

Public Function ToUpper(ByVal Text As String) As String
Dim Cp As Integer
Dim Pos As Long
Dim Index As Long
Dim Ch As String * 1
Dim Result As String

Result = Text

For Pos = 1 To Len(Text)
Ch = Mid$(Result, Pos, 1)

Select Case Ch
Case "A" To "Z"
' Nothing to do

Case "a" To "z"
Cp = AscW(Ch)
Ch = ChrW$(Cp - 32)

Case Else
If Not IsInit_ Then Init
Cp = AscW(Ch)
Index = BinarySearch(CodePoints_, Cp, FirstIndex:=0, Step:=NO_OF_COLS)
If Index <> -1 Then Ch = ChrW$(CodePoints_(Index + 1))
End Select

Mid$(Result, Pos, 1) = Ch
Next

ToUpper = Result
End Function

Public Function ToLower(ByVal Text As String) As String
Dim Cp As Integer
Dim Pos As Long
Dim Index As Long
Dim Ch As String * 1
Dim Result As String

Result = Text

For Pos = 1 To Len(Text)
Ch = Mid$(Result, Pos, 1)

Select Case Ch
Case "A" To "Z"
Cp = AscW(Ch)
Ch = ChrW$(Cp + 32)

Case "a" To "z"
' Nothing to do

Case Else
If Not IsInit_ Then Init
Cp = AscW(Ch)
Index = BinarySearch(CodePoints_, Cp, FirstIndex:=3, Step:=NO_OF_COLS)

If Index <> 2 Then
Index = CodePoints_(Index + 1)
If Index <> -1 Then Ch = ChrW$(CodePoints_(Index * NO_OF_COLS))
End If
End Select

Mid$(Result, Pos, 1) = Ch
Next

ToLower = Result
End Function

Public Function ToTitle(ByVal Text As String) As String
Dim ToUp As Boolean
Dim Cp As Integer
Dim Pos As Long
Dim Index As Long
Dim Ch As String * 1
Dim Result As String

Result = Text
ToUp = True

For Pos = 1 To Len(Text)
Ch = Mid$(Result, Pos, 1)
Cp = AscW(Ch)

If IsLetter(Cp) Then
If ToUp Then
ToUp = False

Select Case Ch
Case "A" To "Z"
' Nothing to do

Case "a" To "z"
Ch = ChrW$(Cp - 32)

Case Else
If Not IsInit_ Then Init
' Search for a lower case character.
Index = BinarySearch(CodePoints_, Cp, FirstIndex:=0, Step:=NO_OF_COLS)

If Index = -1 Then
' Search for an upper case character.
Index = BinarySearch(CodePoints_, Cp, FirstIndex:=3, Step:=NO_OF_COLS)

If Index <> 2 Then
Index = CodePoints_(Index + 1) * NO_OF_COLS
Ch = ChrW$(CodePoints_(Index + 2))
End If
Else
Ch = ChrW$(CodePoints_(Index + 2))
End If
End Select
Else
Ch = ToLower(Ch)
End If
Else
ToUp = True
End If

Mid$(Result, Pos, 1) = Ch
Next

ToTitle = Result
End Function

Private Function BinarySearch( _
ByRef SourceArray As Variant, _
ByVal Target As Variant, _
Optional ByVal FirstIndex As Integer, _
Optional ByVal Step As Integer = 1 _
) As Long
Dim LeftPoint As Long
Dim RightPoint As Long
Dim MiddlePoint As Long
Dim ResultIndex As Long
ResultIndex = FirstIndex - 1

RightPoint = UBound(SourceArray) - Step + 1 + FirstIndex
LeftPoint = FirstIndex

Do While LeftPoint <= RightPoint
MiddlePoint = (LeftPoint + RightPoint) \ (2 * Step)
MiddlePoint = MiddlePoint * Step + FirstIndex

Select Case SourceArray(MiddlePoint)
Case Is < Target
LeftPoint = MiddlePoint + Step

Case Is > Target
RightPoint = MiddlePoint - Step

Case Else
ResultIndex = MiddlePoint
Exit Do
End Select
Loop

BinarySearch = ResultIndex
End Function

' The first (high) surrogate is a 16-bit code value in the range U+D800 to U+DBFF.
Private Function IsHighSurrogate(ByVal Character As Integer) As Boolean
IsHighSurrogate = Character >= -10240 And Character <= -9217 Or Character >= 55296 And Character <= 56319
End Function

' The second (low) surrogate is a 16-bit code value in the range U+DC00 to U+DFFF.
Private Function IsLowSurrogate(ByVal Character As Integer) As Boolean
IsLowSurrogate = Character >= -9216 And Character <= -8193 Or Character >= 56320 And Character <= 57343
End Function

Public Function IsSurrogate(ByVal Character As Integer) As Boolean
IsSurrogate = IsLowSurrogate(Character) Or IsHighSurrogate(Character)
End Function

Public Function IsLetter(ByVal CodePoint As Integer) As Boolean
Select Case CodePoint
Case -32768 To -24645, -24576 To -23412, -22761 To -22758, -22528 To -22527, -22525 To -22523, _
-22521 To -22518, -22516 To -22494, -22464 To -22413, -21504 To -10333, -1792 To -1491, _
-1488 To -1430, -1424 To -1319, -1280 To -1274, -1261 To -1257, -1251, -1249 To -1240, _
-1238 To -1226, -1224 To -1220, -1218, -1216, -1215, -1213, -1212, -1210 To -1103, _
-1069, -1068 To -707, -688 To -625, -622 To -569, -528 To -517, -400 To -396, -394 To -260, _
-223 To -198, -191 To -166, -154 To -66, -62 To -57, -54 To -49, -46 To -41, -38 To -36, _
65 To 90, 97 To 122, 170, 181, 186, 192 To 214, 216 To 246, 248 To 705, 710 To 721, _
736 To 740, 750, 890 To 893, 902, 904 To 906, 908, 910 To 929, 931 To 974, 976 To 1013, _
1015 To 1153, 1162 To 1299, 1329 To 1366, 1369, 1377 To 1415, 1488 To 1514, 1520 To 1522, _
1569 To 1594, 1600 To 1610, 1646, 1647, 1649 To 1747, 1749, 1765, 1766, 1774, 1775, _
1786 To 1788, 1791, 1808, 1810 To 1839, 1869 To 1901, 1920 To 1957, 1969, 1994 To 2026, 2036, _
2037, 2042
IsLetter = True
End Select
End Function
End Module

Private Module VariantEnumeratorHome
Option Explicit

Private Declare Function HeapFree Lib "kernel32" ( _
ByVal hHeap As LongPtr, _
ByVal dwFlags As Long, _
ByRef lpMem As LongPtr _
) As Long

Public Declare Function GetProcessHeap Lib "kernel32" () As LongPtr

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, _
ByVal Source As LongPtr, _
ByVal Length As Long _
)

Public Type IEnumVariantType
VTable As LongPtr '''''Address of the "virtual table" below.
QueryInterface As LongPtr '''''Interface IUnknown.
AddRef As LongPtr '''''Interface IUnknown.
Release As LongPtr '''''Interface IUnknown.
NextItem As LongPtr '''''Interface IEnumVARIANT.
Skip As LongPtr '''''Interface IEnumVARIANT.
Reset As LongPtr '''''Interface IEnumVARIANT.
Clone As LongPtr '''''Interface IEnumVARIANT.
Count As Long '''''Reference counter.
Ptr As LongPtr '''''Pointer to this structure's allocated memory.
Ref As LongPtr '''''Reference to VariantEnumerator.
Data As Variant '''''Container to user's data.
Parent As LongPtr '''''Reference to object being iterated.
End Type

Public Function QueryInterfaceEntry(ByRef This As IEnumVariantType, ByVal iid As Long, ByRef ppvObject As Long) As Long
' Increment reference count.
This.Count = This.Count + 1

' Return pointer to IEnumVariantType structure.
ppvObject = VarPtr(This)
End Function

Public Function AddRefEntry(ByRef This As IEnumVariantType) As Long
' Increment reference count.
This.Count = This.Count + 1

' Return it.
AddRefEntry = This.Count
End Function

Public Function ReleaseEntry(ByRef This As IEnumVariantType) As Long
' Decrement reference count.
This.Count = This.Count - 1

' Return it.
ReleaseEntry = This.Count

' If there's no more references, deallocates IEnumVariantType's memory.
If This.Count = 0 Then
DecRefCount This.Parent
HeapFree GetProcessHeap, 0, This.Ptr
End If
End Function

Public Function NextEntry( _
ByRef This As IEnumVariantType, _
ByVal celt As Long, _
ByRef rgvar As Variant, _
ByVal pceltFetched As Long _
) As Long
If celt = 0 Then celt = 1
GetEnumerator(This.Ref).OnNextItem celt, rgvar, pceltFetched, This.Data

' If qunatity of returned items is lower than what has been asked, iteration is over.
If pceltFetched < celt Then NextEntry = 1
End Function

Public Function SkipEntry(ByRef This As IEnumVariantType, ByVal celt As Long) As Long
GetEnumerator(This.Ref).OnSkip celt, This.Data
End Function

Public Function ResetEntry(ByRef This As IEnumVariantType) As Long
GetEnumerator(This.Ref).OnReset This.Data
End Function

Public Function CloneEntry(ByRef This As IEnumVariantType, ByRef ppEnum As IEnumVARIANT) As Long
GetEnumerator(This.Ref).OnClone ppEnum, This.Data
End Function

Private Function GetEnumerator(ByRef Ptr As LongPtr) As VariantEnumerator
Dim Obj As VariantEnumerator
Dim Res As VariantEnumerator
Dim Nil As LongPtr

' Copy pointer to a temporary object.
CopyMemory Destination:=Obj, Source:=VarPtr(Ptr), Length:=Len(Ptr)

' Get the legal object.
Set Res = Obj

' Free the ilegal object.
CopyMemory Destination:=Obj, Source:=VarPtr(Nil), Length:=Len(Nil)

' Return the "rehydrated" object.
Set GetEnumerator = Res
End Function

Private Sub DecRefCount(ByRef Ptr As LongPtr)
Dim Dummy As Object

CopyMemory Destination:=ObjPtr(Dummy), Source:=Ptr, Length:=Len(Ptr)
End Sub
End Module

Public Class VariantEnumerator
Option Explicit
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As LongPtr, ByVal dwFlags As Long, ByVal dwBytes As Long) As LongPtr

Public Event NextItem(ByVal Qty As Long, ByRef Items As Variant, ByRef Returned As Long, ByRef Data As Variant)
Public Event Skip(ByVal Qty As Long, ByRef Data As Variant)
Public Event Reset(ByRef Data As Variant)
Public Event Clone(ByRef Obj As Variant, ByRef Data As Variant)

Public Iterator Function NewEnum(ByVal ParentObj As Object) As IUnknown
Dim Ptr As LongPtr
Dim Obj As IEnumVariantType

IncRefCount ParentObj
Ptr = HeapAlloc(GetProcessHeap, dwFlags:=0, dwBytes:=Len(Obj))

With Obj
.VTable = Ptr + 4
.QueryInterface = GetProc(AddressOf QueryInterfaceEntry)
.AddRef = GetProc(AddressOf AddRefEntry)
.Release = GetProc(AddressOf ReleaseEntry)
.NextItem = GetProc(AddressOf NextEntry)
.Skip = GetProc(AddressOf SkipEntry)
.Reset = GetProc(AddressOf ResetEntry)
.Clone = GetProc(AddressOf CloneEntry)
.Count = 1
.Ptr = Ptr
.Ref = ObjPtr(Me)
.Parent = ObjPtr(ParentObj)
End With

' Copy structure to the allocated memory
CopyMemory Destination:=ByVal Ptr, Source:=VarPtr(Obj), Length:=Len(Obj)
' Return pointer as an IUnknown.
CopyMemory NewEnum, Source:=VarPtr(Ptr), Length:=Len(Ptr)
End Function

Friend Sub OnNextItem(ByVal Qty As Long, ByRef Items As Variant, ByRef Returned As Long, ByRef Data As Variant)
RaiseEvent NextItem(Qty, Items, Returned, Data)
End Sub

Friend Sub OnSkip(ByVal Qty As Long, ByRef Data As Variant)
RaiseEvent Skip(Qty, Data)
End Sub

Friend Sub OnReset(ByRef Data As Variant)
RaiseEvent Reset(Data)
End Sub

Friend Sub OnClone(ByRef Obj As Variant, ByRef Data As Variant)
RaiseEvent Clone(Obj, Data)
End Sub

Private Function GetProc(ByRef Proc As LongPtr) As LongPtr
GetProc = Proc
End Function

Private Sub IncRefCount(ByRef Obj As Object)
Dim Dummy As Object
Dim Nil As LongPtr

Set Dummy = Obj
CopyMemory Destination:=Dummy, Source:=VarPtr(Nil), Length:=Len(Nil)
End Sub
End Class

Private Class KLNode
Option Explicit

Public NextNode As KLNode
Public Key As String
Public Value As Variant
End Class

Private Class KLEnumerator
Option Explicit

Private Index_ As Long
Private List_ As KeyedList
Private WithEvents VbEnum As VariantEnumerator

Public Property Set List(ByVal Value As KeyedList)
Set List_ = Value
Index_ = List_.Base
Set VbEnum = New VariantEnumerator
End Property

Public Iterator Function NewEnum() As IUnknown
Set NewEnum = VbEnum.NewEnum(Me)
End Function

Private Sub VbEnum_Clone(ByRef Obj As Variant, ByRef Data As Variant)
Debug.Assert False
End Sub

Private Sub VbEnum_NextItem(ByVal Qty As Long, ByRef Items As Variant, ByRef Returned As Long, ByRef Data As Variant)
If Index_ > List_.Count Then Exit Sub

If IsObject(List_(Index_)) Then Set Items = List_(Index_) Else Items = List_(Index_)
Index_ = Index_ + 1
Returned = 1
End Sub

Private Sub VbEnum_Reset(ByRef Data As Variant)
Index_ = List_.Base
End Sub

Private Sub VbEnum_Skip(ByVal Qty As Long, ByRef Data As Variant)
Index_ = Index_ + Qty
End Sub
End Class

Public Class KeyedList
Option Explicit
Private ReadOnly_ As Boolean
Private Base_ As Integer
Private ID_ As Long
Private Count_ As Long
Private Root_ As KLNode
Private Last_ As KLNode
Private CompareMode_ As VbCompareMethod

Private Sub Class_Initialize()
ID_ = &H80000000
Base = 1
End Sub

Private Sub Class_Terminate()
ReadOnly_ = False
Clear
End Sub

Public Sub AddKeyValue(ByVal Key As String, ByVal Item As Variant)
Add Item, Key
End Sub

Public Sub Add(ByVal Item As Variant, Optional ByVal Key As Variant)
Const Id = "72E0DEDF0CD34921A650C8DD99F21A68_"
Dim NewKey As String
Dim NewNode As KLNode

If ReadOnly_ Then Err.Raise 5

Select Case VarType(Key)
Case vbString
NewKey = CStr(Key)

Case vbError
If Not IsMissing(Key) Then Err.Raise 13

NewKey = Id & Hex$(ID_)
ID_ = ID_ + 1

Case Else
Err.Raise 13
End Select

If Root_ Is Nothing Then
Set Root_ = New KLNode
Root_.Key = NewKey
If IsObject(Item) Then Set Root_.Value = Item Else Root_.Value = Item
Set Last_ = Root_

Else
If Not FindNode(NewKey) Is Nothing Then Err.Raise 457

Set NewNode = New KLNode
NewNode.Key = NewKey
If IsObject(Item) Then Set NewNode.Value = Item Else NewNode.Value = Item

Set Last_.NextNode = NewNode
Set Last_ = NewNode
End If

Count_ = Count_ + 1
End Sub

Public Property Get Count() As Long
Count = Count_
End Property

Public Default Property Get Item(ByVal Index As Variant) As Variant
Dim Node As KLNode

Set Node = FindNode(Index)
If Node Is Nothing Then Err.Raise 5
If IsObject(Node.Value) Then Set Item = Node.Value Else Item = Node.Value
End Property

Public Property Get Exists(ByVal Key As String) As Boolean
Exists = Not FindNode(Key) Is Nothing
End Property

Public Property Get Base() As Integer
Base = Base_
End Property

Public Property Let Base(ByVal Value As Integer)
If ReadOnly_ Then Err.Raise 5
Base_ = Value
End Property

Public Property Get CompareMode() As VbCompareMethod
CompareMode = CompareMode_
End Property

Public Property Let CompareMode(ByVal Value As VbCompareMethod)
If ReadOnly_ Then Err.Raise 5
CompareMode_ = Value
End Property

Public Sub Remove(ByVal Index As Variant)
Dim Found As Boolean
Dim Idx As Long
Dim Key As String
Dim CurNode As KLNode
Dim PrvNode As KLNode

If ReadOnly_ Then Err.Raise 5
Set CurNode = Root_

If VarType(Index) = vbString Then
Key = CStr(Index)

Do Until CurNode Is Nothing
If StrComp(CurNode.Key, Key, CompareMode) = 0 Then
If Not PrvNode Is Nothing Then Set PrvNode.NextNode = CurNode.NextNode
Found = True
Exit Do
End If

Set PrvNode = CurNode
Set CurNode = CurNode.NextNode
Loop
Else
Idx = CLng(Index)
Idx = Idx - Base

Do Until CurNode Is Nothing
If Idx = 0 Then
If CurNode Is Root_ Then
Set Root_ = CurNode.NextNode

ElseIf Not PrvNode Is Nothing Then
Set PrvNode.NextNode = CurNode.NextNode
End If

If CurNode Is Last_ Then Set Last_ = PrvNode
Found = True
Exit Do
End If

Idx = Idx - 1
Set PrvNode = CurNode
Set CurNode = CurNode.NextNode
Loop
End If

If Found Then Count_ = Count_ - 1 Else Err.Raise 5
End Sub

Public Function NewEnum() As IUnknown
Dim It As KLEnumerator

Set It = New KLEnumerator
Set It.List = Me
Set NewEnum = It.NewEnum
End Function

Public Sub Clear()
Dim CurrNode As KLNode
Dim NextNode As KLNode

If ReadOnly_ Then Err.Raise 5
Set CurrNode = Root_
Set Root_ = Nothing

Do Until CurrNode Is Nothing
Set NextNode = CurrNode.NextNode
Set CurrNode.NextNode = Nothing
Set CurrNode = NextNode
Loop

Count_ = 0
End Sub

Private Function FindNode(ByVal Index As Variant) As KLNode
Dim Idx As Long
Dim Node As KLNode

If VarType(Index) = vbString Then
Set Node = FindKey(CStr(Index))
Else
Idx = CLng(Index)
Idx = Idx - Base

If Idx >= 0 Then
Set Node = Root_
Do Until Node Is Nothing Or Idx = 0
Set Node = Node.NextNode
Idx = Idx - 1
Loop
End If
End If

Set FindNode = Node
End Function

Private Function FindKey(ByVal Key As String) As KLNode
Dim Node As KLNode

Set Node = Root_

Do Until Node Is Nothing
If StrComp(Node.Key, Key, CompareMode) = 0 Then
Set FindKey = Node
Exit Function
End If

Set Node = Node.NextNode
Loop
End Function

Public Property Get IndexOf(ByVal Key As String) As Long
Dim Count As Long
Dim Node As KLNode

Set Node = Root_

Do Until Node Is Nothing
If StrComp(Node.Key, Key, CompareMode) = 0 Then
IndexOf = Count + Base
Exit Property
End If

Set Node = Node.NextNode
Count = Count + 1
Loop
End Property

Public Sub AddValues(ParamArray Values())
Dim Value As Variant

For Each Value In Values
Add Value
Next
End Sub

Public Sub AddKVPairs(ParamArray KeyValuePairs())
Dim Idx As Long
Dim Udx As Long

Udx = UBound(KeyValuePairs)
If Udx Mod 2 = 0 Then Err.Raise 5

For Idx = 0 To Udx Step 2
Add KeyValuePairs(Idx + 1), KeyValuePairs(Idx)
Next
End Sub

Public Property Get ReadOnly() As Boolean
ReadOnly = ReadOnly_
End Property

Public Property Let ReadOnly(ByVal Value As Boolean)
If ReadOnly_ Then Err.Raise 5
ReadOnly_ = Value
End Property
End Class

Public Module Vocabulary
Option Explicit

' Contextual in VB6
Public Property Get vAccess() As String
vAccess = "Access"
End Property

Public Property Get vAddressOf() As String
vAddressOf = "AddressOf"
End Property

' Contextual in VB6
Public Property Get vAlias() As String
vAlias = "Alias"
End Property

Public Property Get vAnd() As String
vAnd = "And"
End Property

' New!
Public Property Get vAndAlso() As String
vAndAlso = "AndAlso"
End Property

Public Property Get vAny() As String
vAny = "Any"
End Property

' Contextual in VB6
Public Property Get vAppend() As String
vAppend = "Append"
End Property

Public Property Get vAs() As String
vAs = "As"
End Property

Public Property Get vAttribute() As String
vAttribute = "Attribute"
End Property

' Contextual in VB6
Public Property Get vBase() As String
vBase = "Base"
End Property

' Contextual in VB6
Public Property Get vBinary() As String
vBinary = "Binary"
End Property

Public Property Get vBoolean() As String
vBoolean = "Boolean"
End Property

Public Property Get vByRef() As String
vByRef = "ByRef"
End Property

Public Property Get vByVal() As String
vByVal = "ByVal"
End Property

Public Property Get vByte() As String
vByte = "Byte"
End Property

Public Property Get vCall() As String
vCall = "Call"
End Property

Public Property Get vCase() As String
vCase = "Case"
End Property

Public Property Get vCDecl() As String
vCDecl = "CDecl"
End Property

Public Property Get vCircle() As String
vCircle = "Circle"
End Property

' New!
Public Property Get vClass() As String
vClass = "Class"
End Property

Public Property Get vClose() As String
vClose = "Close"
End Property

' Contextual in VB6
Public Property Get vCompare() As String
vCompare = "Compare"
End Property

Public Property Get vConst() As String
vConst = "Const"
End Property

' New!
Public Property Get vContinue() As String
vContinue = "Continue"
End Property

Public Property Get vCurrency() As String
vCurrency = "Currency"
End Property

Public Property Get vDate() As String
vDate = "Date"
End Property

Public Property Get vDecimal() As String
vDecimal = "Decimal"
End Property

Public Property Get vDebug() As String
vDebug = "Debug"
End Property

Public Property Get vDeclare() As String
vDeclare = "Declare"
End Property

' New!
Public Property Get vDefault() As String
vDefault = "Default"
End Property

Public Property Get vDefBool() As String
vDefBool = "DefBool"
End Property

Public Property Get vDefByte() As String
vDefByte = "DefByte"
End Property

Public Property Get vDefCur() As String
vDefCur = "DefCur"
End Property

Public Property Get vDefDate() As String
vDefDate = "DefDate"
End Property

Public Property Get vDefDbl() As String
vDefDbl = "DefDbl"
End Property

Public Property Get vDefDec() As String
vDefDec = "DefDec"
End Property

Public Property Get vDefInt() As String
vDefInt = "DefInt"
End Property

Public Property Get vDefLng() As String
vDefLng = "DefLng"
End Property

' New!
Public Property Get vDefLngLng() As String
vDefLngLng = "DefLngLng"
End Property

' New!
Public Property Get vDefLngPtr() As String
vDefLngPtr = "DefLngPtr"
End Property

Public Property Get vDefObj() As String
vDefObj = "DefObj"
End Property

Public Property Get vDefSng() As String
vDefSng = "DefSng"
End Property

Public Property Get vDefStr() As String
vDefStr = "DefStr"
End Property

Public Property Get vDefVar() As String
vDefVar = "DefVar"
End Property

Public Property Get vDim() As String
vDim = "Dim"
End Property

Public Property Get vDo() As String
vDo = "Do"
End Property

Public Property Get vDouble() As String
vDouble = "Double"
End Property

Public Property Get vEach() As String
vEach = "Each"
End Property

Public Property Get vElseIf() As String
vElseIf = "ElseIf"
End Property

Public Property Get vElse() As String
vElse = "Else"
End Property

Public Property Get vEmpty() As String
vEmpty = "Empty"
End Property

Public Property Get vEnd() As String
vEnd = "End"
End Property

Public Property Get vEndIf() As String
vEndIf = "EndIf"
End Property

Public Property Get vEnum() As String
vEnum = "Enum"
End Property

Public Property Get vEqv() As String
vEqv = "Eqv"
End Property

Public Property Get vErase() As String
vErase = "Erase"
End Property

' Contextual in VB6
Public Property Get vError() As String
vError = "Error"
End Property

Public Property Get vEvent() As String
vEvent = "Event"
End Property

Public Property Get vExit() As String
vExit = "Exit"
End Property

' Contextual in VB6
Public Property Get vExplicit() As String
vExplicit = "Explicit"
End Property

Public Property Get vFalse() As String
vFalse = "False"
End Property

Public Property Get vFor() As String
vFor = "For"
End Property

Public Property Get vFriend() As String
vFriend = "Friend"
End Property

Public Property Get vFunction() As String
vFunction = "Function"
End Property

Public Property Get vGet() As String
vGet = "Get"
End Property

Public Property Get vGlobal() As String
vGlobal = "Global"
End Property

Public Property Get vGoSub() As String
vGoSub = "GoSub"
End Property

Public Property Get vGoTo() As String
vGoTo = "GoTo"
End Property

Public Property Get vIf() As String
vIf = "If"
End Property

Public Property Get vImp() As String
vImp = "Imp"
End Property

Public Property Get vImplements() As String
vImplements = "Implements"
End Property

Public Property Get vIn() As String
vIn = "In"
End Property

Public Property Get vInput() As String
vInput = "Input"
End Property

Public Property Get vInteger() As String
vInteger = "Integer"
End Property

Public Property Get vIs() As String
vIs = "Is"
End Property

' New!
Public Property Get vIsNot() As String
vIsNot = "IsNot"
End Property

Public Property Get vLet() As String
vLet = "Let"
End Property

' Contextual in VB6
Public Property Get vLib() As String
vLib = "Lib"
End Property

Public Property Get vLike() As String
vLike = "Like"
End Property

' Contextual in VB6
Public Property Get vLine() As String
vLine = "Line"
End Property

Public Property Get vLock() As String
vLock = "Lock"
End Property

Public Property Get vLocal() As String
vLocal = "Local"
End Property

Public Property Get vLong() As String
vLong = "Long"
End Property

' New!
Public Property Get vLongPtr() As String
vLongPtr = "LongPtr"
End Property

' New!
Public Property Get vLongLong() As String
vLongLong = "LongLong"
End Property

Public Property Get vLoop() As String
vLoop = "Loop"
End Property

Public Property Get vLSet() As String
vLSet = "LSet"
End Property

Public Property Get vLen() As String
vLen = "Len"
End Property

Public Property Get vMe() As String
vMe = "Me"
End Property

Public Property Get vMod() As String
vMod = "Mod"
End Property

' Upgraded from contextual keyword (Option Private Module) to keyword
Public Property Get vModule() As String
vModule = "Module"
End Property

' Contextual in VB6
Public Property Get vName() As String
vName = "Name"
End Property

Public Property Get vNew() As String
vNew = "New"
End Property

Public Property Get vNext() As String
vNext = "Next"
End Property

Public Property Get vNot() As String
vNot = "Not"
End Property

Public Property Get vNothing() As String
vNothing = "Nothing"
End Property

Public Property Get vNull() As String
vNull = "Null"
End Property

' Contextual in VB6
Public Property Get vObject() As String
vObject = "Object"
End Property

Public Property Get vOn() As String
vOn = "On"
End Property

Public Property Get vOpen() As String
vOpen = "Open"
End Property

Public Property Get vOption() As String
vOption = "Option"
End Property

Public Property Get vOptional() As String
vOptional = "Optional"
End Property

Public Property Get vOr() As String
vOr = "Or"
End Property

' New!
Public Property Get vOrElse() As String
vOrElse = "OrElse"
End Property

' Contextual in VB6
Public Property Get vOutput() As String
vOutput = "Output"
End Property

Public Property Get vParamArray() As String
vParamArray = "ParamArray"
End Property

Public Property Get vPSet() As String
vPSet = "PSet"
End Property

Public Property Get vPreserve() As String
vPreserve = "Preserve"
End Property

Public Property Get vPrint() As String
vPrint = "Print"
End Property

Public Property Get vPrivate() As String
vPrivate = "Private"
End Property

Public Property Get vProperty() As String
vProperty = "Property"
End Property

' New!
Public Property Get vPtrSafe() As String
vPtrSafe = "PtrSafe"
End Property

Public Property Get vPublic() As String
vPublic = "Public"
End Property

Public Property Get vPut() As String
vPut = "Put"
End Property

Public Property Get vRaiseEvent() As String
vRaiseEvent = "RaiseEvent"
End Property

' Contextual in VB6
Public Property Get vRandom() As String
vRandom = "Random"
End Property

' Contextual in VB6
Public Property Get vRead() As String
vRead = "Read"
End Property

Public Property Get vReDim() As String
vReDim = "ReDim"
End Property

Public Property Get vRem() As String
vRem = "Rem"
End Property

' Contextual in VB6
Public Property Get vReset() As String
vReset = "Reset"
End Property

Public Property Get vResume() As String
vResume = "Resume"
End Property

Public Property Get vReturn() As String
vReturn = "Return"
End Property

Public Property Get vRSet() As String
vRSet = "RSet"
End Property

Public Property Get vSeek() As String
vSeek = "Seek"
End Property

Public Property Get vSelect() As String
vSelect = "Select"
End Property

Public Property Get vSet() As String
vSet = "Set"
End Property

Public Property Get vScale() As String
vScale = "Scale"
End Property

Public Property Get vShared() As String
vShared = "Shared"
End Property

Public Property Get vSingle() As String
vSingle = "Single"
End Property

Public Property Get vStatic() As String
vStatic = "Static"
End Property

Rem Keyword in VB6, demoted to contextual
Public Property Get vSpc() As String
vSpc = "Spc"
End Property

' Contextual in VB6
Public Property Get vStep() As String
vStep = "Step"
End Property

Rem Keyword in VB6, demoted to contextual
Public Property Get vTab() As String
vTab = "Tab"
End Property

Public Property Get vStop() As String
vStop = "Stop"
End Property

Public Property Get vString() As String
vString = "String"
End Property

Public Property Get vSub() As String
vSub = "Sub"
End Property

' Contextual in VB6
Public Property Get vText() As String
vText = "Text"
End Property

Public Property Get vThen() As String
vThen = "Then"
End Property

Public Property Get vTo() As String
vTo = "To"
End Property

Public Property Get vTrue() As String
vTrue = "True"
End Property

Public Property Get vType() As String
vType = "Type"
End Property

Public Property Get vTypeOf() As String
vTypeOf = "TypeOf"
End Property

Public Property Get vUnlock() As String
vUnlock = "Unlock"
End Property

Public Property Get vUntil() As String
vUntil = "Until"
End Property

Public Property Get vVariant() As String
vVariant = "Variant"
End Property

Public Property Get vVoid() As String
' Intentionally blank
End Property

Public Property Get vWend() As String
vWend = "Wend"
End Property

Public Property Get vWhile() As String
vWhile = "While"
End Property

' Contextual in VB6
Public Property Get vWidth() As String
vWidth = "Width"
End Property

Public Property Get vWith() As String
vWith = "With"
End Property

Public Property Get vWithEvents() As String
vWithEvents = "WithEvents"
End Property

Public Property Get vWrite() As String
vWrite = "Write"
End Property

Public Property Get vXor() As String
vXor = "Xor"
End Property
End Module

Public Class Scanner
Option Explicit

Private File_ As Integer
Private RunningLine_ As Long
Private RunningColumn_ As Long
Private FrozenColumn_ As Long
Private PreviousColumn_ As Long
Private FilePath_ As String
Private Ids_ As KeyedList
Private Keywords_ As KeyedList
Private Operators_ As KeyedList
Private Contextuals_ As KeyedList

Private Const BS_ As Integer = 8 ' Backspace. Used in line continuation
Private Const LF_ As Integer = 10 ' Line feed
Private Const CR_ As Integer = 13 ' Carriage return
Private Const SP_ As Integer = 32 ' Space
Private Const US_ As Integer = 95 ' Underscore
Private Const CRLF_ As Long = &HA000D

Public Enum KeywordConstants
kwAny = 1
kwAs ' 2
kwAttribute ' 3
kwBoolean ' 4
kwByRef ' 5
kwByte ' 6
kwByVal ' 7
kwCall ' 8
kwCase ' 9
kwCDecl ' 10
kwCircle ' 11
kwClass ' 12
kwClose ' 13
kwConst ' 14
kwContinue ' 15
kwCurrency ' 16
kwDate ' 17
kwDebug ' 18
kwDeclare ' 19
kwDefault ' 20
kwDefBool ' 21
kwDefByte ' 22
kwDefCur ' 23
kwDefDate ' 24
kwDefDbl ' 25
kwDefDec ' 26
kwDefInt ' 27
kwDefLng ' 28
kwDefLngLng ' 29
kwDefLngPtr ' 30
kwDefObj ' 31
kwDefSng ' 32
kwDefStr ' 33
kwDefVar ' 34
kwDim ' 35
kwDo ' 36
kwDouble ' 37
kwEach ' 38
kwElse ' 39
kwElseIf ' 40
kwEmpty ' 41
kwEnd ' 42
kwEndIf ' 43
kwEnum ' 44
kwErase ' 45
kwEvent ' 46
kwExit ' 47
kwFalse ' 48
kwFor ' 49
kwFriend ' 50
kwFunction ' 51
kwGet ' 52
kwGlobal ' 53
kwGoSub ' 54
kwGoTo ' 55
kwIf ' 56
kwImplements ' 57
kwIn ' 58
kwInput ' 59
kwInteger ' 60
kwLet ' 61
kwLocal ' 62
kwLong ' 63
kwLongLong ' 64
kwLongPtr ' 65
kwLoop ' 66
kwLSet ' 67
kwMe ' 68
kwModule ' 69
kwNext ' 70
kwNothing ' 71
kwNull ' 72
kwOn ' 73
kwOpen ' 74
kwOption ' 75
kwOptional ' 76
kwParamArray ' 77
kwPreserve ' 78
kwPrint ' 79
kwPrivate ' 80
kwPSet ' 81
kwPublic ' 82
kwPut ' 83
kwRaiseEvent ' 84
kwReDim ' 85
kwRem ' 86
kwResume ' 87
kwReturn ' 88
kwRSet ' 89
kwScale ' 90
kwSeek ' 91
kwSelect ' 92
kwSet ' 93
kwSingle ' 94
kwStatic ' 95
kwStop ' 96
kwString ' 97
kwSub ' 98
kwThen ' 99
kwTo ' 100
kwTrue ' 101
kwType ' 102
kwUnlock ' 103
kwUntil ' 104
kwVariant ' 105
kwVoid ' 106
kwWend ' 107
kwWhile ' 108
kwWith ' 109
kwWithEvents ' 110
kwWrite ' 111
End Enum

Public Enum ContextualConstants
cxAccess = kwWrite + 1 ' 112
cxAlias ' 2 / 113
cxAppend ' 3 / 114
cxBase ' 4 / 115
cxBinary ' 5 / 116
cxCompare ' 6 / 117
cxDecimal ' 7 / 118
cxError ' 8 / 119
cxExplicit ' 9 / 120
cxLen ' 10 / 121
cxLib ' 11 / 122
cxLine ' 12 / 123
cxLock ' 13 / 124
cxName ' 14 / 125
cxObject ' 15 / 126
cxOutput ' 16 / 127
cxProperty ' 17 / 128
cxPtrSafe ' 18 / 129
cxRandom ' 19 / 130
cxRead ' 20 / 131
cxReset ' 21 / 132
cxShared ' 22 / 133
cxStep ' 23 / 134
cxText ' 24 / 135
cxWidth ' 25 / 136
End Enum

Public Enum OperatorConstants
opAddressOf = 1
opAndAlso ' 2
opIs ' 3
opIsNot ' 4
opLike ' 5
opNew ' 6
opNot ' 7
opOrElse ' 8
opTypeOf ' 9
opId ' 10 (~+)
opNeg ' 10 (~-)
opLt ' 11 (<)
opLe ' 12 (<=)
opEq ' 13 (=)
opGe ' 14 (>=)
opGt ' 15 (>)
opNe ' 16 (<>)
opNamed ' 17 (:=)
opWithDot ' 18 (~.)
opWithBang ' 19 (~!)
opDot ' 20 (.)
opBang ' 21 (!)
opAnd ' 22
opEqv ' 23
opImp ' 24
opMod ' 25
opOr ' 26
opXor ' 27
opSum ' 28 (+)
opSubt ' 29 (-)
opMul ' 30 (*)
opDiv ' 31 (/)
opIntDiv ' 32 (\)
opPow ' 33 (^)
opLSh ' 34 (<<)
opRSh ' 35 (>>)
opURSh ' 36 (>>>)
opConcat ' 37 (&)
opCompAnd ' 38 (And=)
opCompEqv ' 39 (Eqv=)
opCompImp ' 40 (Imp=)
opCompMod ' 41 (Mod=)
opCompOr ' 42 (Or=)
opCompXor ' 43 (Xor=)
opCompSum ' 44 (+=)
opCompSubt ' 45 (-=)
opCompMul ' 46 (*=)
opCompDiv ' 47 (/=)
opCompIntDiv ' 48 (\=)
opCompPow ' 49 (^=)
opCompLSh ' 50 (<<=)
opCompRSh ' 51 (>>=)
opCompURSh ' 52 (>>>=)
opCompConcat ' 53 (&=)
End Enum

Private Sub Class_Initialize()
Dim Values As Variant
Dim Value As Variant

RunningLine_ = 0
RunningColumn_ = 1

Set Ids_ = New KeyedList
Ids_.CompareMode = vbTextCompare

Set Keywords_ = New KeyedList
Keywords_.CompareMode = vbTextCompare

' Keyword order must follow the Enum's one.
Values = Array(vAny, vAs, vAttribute, vBoolean, vByRef, vByte, vByVal, vCall, vCase, _
vCDecl, vCircle, vClass, vClose, vConst, vContinue, vCurrency, vDate, vDebug, vDeclare, _
vDefault, vDefBool, vDefByte, vDefCur, vDefDate, vDefDbl, vDefDec, vDefInt, vDefLng, vDefLngLng, _
vDefLngPtr, vDefObj, vDefSng, vDefStr, vDefVar, vDim, vDo, vDouble, vEach, vElse, vElseIf, _
vEmpty, vEnd, vEndIf, vEnum, vEvent, vExit, vFalse, vFor, vFriend, vFunction, vGet, _
vGlobal, vGoSub, vGoTo, vIf, vImplements, vIn, vInput, vInteger, vLet, vLong, _
vLongLong, vLongPtr, vLoop, vLSet, vMe, vModule, vNext, vNothing, vNull, vOn, vOpen, _
vOption, vOptional, vParamArray, vPreserve, vPrint, vPrivate, vPSet, vPublic, vPut, _
vRaiseEvent, vReDim, vRem, vResume, vReturn, vRSet, vScale, vSeek, vSelect, vSet, vSingle, _
vStatic, vStop, vString, vSub, vThen, vTo, vTrue, vType, vUnlock, vUntil, vVariant, vVoid, vWend, _
vWhile, vWith, vWithEvents, vWrite)

For Each Value In Values
Keywords_.Add Value, Value
Next

Keywords_.ReadOnly = True

Set Contextuals_ = New KeyedList
Contextuals_.CompareMode = vbTextCompare
Values = Array(vAccess, vAlias, vAppend, vBase, vBinary, vCompare, vDecimal, vError, vExplicit, vLen, vLib, vLike, _
vLine, vLock, vName, vObject, vOutput, vProperty, vPtrSafe, vRandom, vRead, vReset, vShared, vSpc, vStep, vTab, vText, vWidth)

For Each Value In Values
Contextuals_.Add Value, Value
Next

Contextuals_.ReadOnly = True

Set Operators_ = New KeyedList
Operators_.CompareMode = vbTextCompare
' Operator order must follow the Enum's one.
Values = Array(vAddressOf, vAndAlso, vIs, vIsNot, vNew, vNot, vOrElse, vTypeOf, _
"~+", "~-", "<", "<=", "=", ">=", ">", "<>", ":=", "~.", "~!", ".", "!", _
vAnd, vEqv, vImp, vMod, vOr, vXor, "+", "-", "*", "/", "\", "^", "<<", ">>", ">>>", "&", _
vAnd & "=", vEqv & "=", vImp & "=", vMod & "=", vOr & "=", vXor & "=", "+=", "-=", "*=", _
"/=", "\=", "^=", "<<=", ">>=", ">>>=", "&=")

For Each Value In Values
Operators_.Add Value, Value
Next

Operators_.ReadOnly = True
End Sub

Private Sub Class_Terminate()
If File_ <> 0 Then Close #File_
End Sub

Private Function AtEnd() As Boolean
AtEnd = Seek(File_) > LOF(File_)
End Function

Public Sub OpenFile(ByVal FilePath As String)
Dim Cp As Integer

FilePath_ = FilePath
If Dir(FilePath) = "" Then Err.Raise 53
File_ = FreeFile
Open FilePath For Binary Access Read Write As #File_

' If the error below happens, we'll let a new-ly created zero-length file behind.
If LOF(File_) = 0 Then Err.Raise 53

''''''''''''''''''''''''''''''''
Seek #File_, LOF(File_) - 3
Cp = GetCodePoint

If Cp <> LF_ Then
Seek #File_, LOF(File_) + 1

Select Case vbNewLine
Case vbCr
Put #File_, , CR_

Case vbLf
Put #File_, , LF_

Case vbCrLf
Put #File_, , CRLF_
End Select
End If

Seek #File_, 1
''''''''''''''''''''''''''''''''

Cp = GetCodePoint
If Cp <> &HFEFF Then UngetChar ChrW$(Cp)
End Sub

Public Property Get Keywords() As KeyedList
Set Keywords = Keywords_
End Property

Public Property Get Contextuals() As KeyedList
Set Contextuals = Contextuals_
End Property

Public Property Get Operators() As KeyedList
Set Operators = Operators_
End Property

Public Property Get Ids() As KeyedList
Set Ids = Ids_
End Property

Public Function GetToken() As Token
Dim Done As Boolean
Dim Cp As Integer
Dim Ch As String * 1
Dim Token As Token

If AtEnd Then
Set GetToken = NewToken(tkEndOfStream)
Exit Function
End If

Do
Done = True
FrozenColumn_ = RunningColumn_
Cp = GetCodePoint
Ch = ToChar(Cp)

Select Case Ch
Case "["
Set Token = ReadEscapedIdentifier

Case """"
Set Token = ReadString

Case "&"
Set Token = ReadAmpersand

Case "#"
Set Token = ReadHash

Case "0" To "9"
Set Token = ReadNumber(Ch)

Case "+"
Set Token = NewToken(tkOperator, opSum)

Case "-"
Set Token = NewToken(tkOperator, opSubt)

Case "*"
Set Token = NewToken(tkOperator, opMul)

Case "/"
Set Token = NewToken(tkOperator, opDiv)

Case "\"
Set Token = NewToken(tkOperator, opIntDiv)

Case "^"
Set Token = NewToken(tkOperator, opPow)

Case "="
Set Token = NewToken(tkOperator, opEq)

Case "."
Set Token = NewToken(tkOperator, opDot)

Case "!"
Set Token = NewToken(tkOperator, opBang)

Case "<"
Set Token = NewToken(tkOperator, opLt)

If Not AtEnd Then
Ch = GetChar

Select Case Ch
Case ">"
Token.Code = opNe

Case "="
Token.Code = opLe

Case "<"
Token.Code = opLSh

Case Else
UngetChar Ch
End Select
End If

Case ">"
Set Token = NewToken(tkOperator, opGt)

If Not AtEnd Then
Ch = GetChar

Select Case Ch
Case "="
Token.Code = opGe

Case ">"
Token.Code = opRSh

If Not AtEnd Then
Ch = GetChar

If Ch = ">" Then
Token.Code = opURSh
Else
UngetChar Ch
End If
End If

Case Else
UngetChar Ch
End Select
End If

Case ":"
Set Token = NewToken(tkSoftLineBreak)

If Not AtEnd Then
Ch = GetChar

If Ch = "=" Then
Token.Kind = tkOperator
Token.Code = opNamed
Else
UngetChar Ch
End If
End If

Case vbLf
Set Token = NewToken(tkHardLineBreak)

Case "'"
Set Token = ReadComment

Case ","
Set Token = NewToken(tkListSeparator)

Case ";"
Set Token = NewToken(tkPrintSeparator)

Case "("
Set Token = NewToken(tkLeftParenthesis)

Case ")"
Set Token = NewToken(tkRightParenthesis)

Case " "
Set Token = NewToken(tkWhiteSpace)

Case vbBack
Set Token = NewToken(tkLineContinuation)

Case "`"
Done = False
DiscardComment
Set Token = New Token

Case Else
If Not IsLetter(Cp) Then Fail "Invalid token: '" & Ch & "'"

Set Token = ReadIdentifier(Cp)

If Token.Kind = tkKeyword Then
If Token.Code = kwRem Then Set Token = ReadComment(IsRem:=True)

ElseIf Token.Kind = tkOperator Then
If Not AtEnd Then
Ch = GetChar

If Ch = "=" Then
Select Case Token.Code
Case opAnd, opEqv, opImp, opMod, opOr, opXor
Token.Code = Token.Code + opCompAnd - opAnd

Case Else
UngetChar Ch
End Select
Else
UngetChar Ch
End If
End If
End If
End Select

Select Case Token.Code
Case opSum, opSubt, opMul, opDiv, opIntDiv, opPow
If Not AtEnd Then
Ch = GetChar

If Ch = "=" Then
Token.Code = Token.Code + opCompSum - opSum
Else
UngetChar Ch
End If
End If
End Select
Loop While Not Done

Set GetToken = Token
End Function

Private Function GetCodePoint() As Integer
Dim CheckLF As Boolean
Dim Cp1 As Integer
Dim Cp2 As Integer
Dim Cp3 As Integer

Cp1 = NextCodePoint
If IsSpace(Cp1) Then Cp1 = SP_

Select Case Cp1
Case SP_
Cp2 = NextCodePoint

If Cp2 = US_ Then
Cp3 = NextCodePoint

Select Case Cp3
Case CR_
CheckLF = True
AdvanceLine
Cp1 = BS_

Case LF_
AdvanceLine
Cp1 = BS_

Case Else
UngetChar ChrW$(Cp3)
UngetChar ChrW$(Cp2)
End Select
Else
UngetChar ChrW$(Cp2)
End If

Case CR_
CheckLF = True
Cp1 = LF_
End Select

If CheckLF Then
Cp2 = NextCodePoint
If Cp2 <> LF_ Then UngetChar ChrW$(Cp2)
End If

If Cp1 = LF_ Then AdvanceLine
GetCodePoint = Cp1
End Function

Private Function NextCodePoint() As Integer
Dim Result As Integer

Get #File_, , Result
RunningColumn_ = RunningColumn_ + 1
NextCodePoint = Result
End Function

Private Function GetChar() As String
Dim Cp As Integer

Cp = GetCodePoint
GetChar = ToChar(Cp)
End Function

Private Function ToChar(ByVal CodePoint As Integer) As String
Dim Bytes(0 To 1) As Byte

Bytes(0) = CodePoint And &HFF
Bytes(1) = ((CodePoint And &HFF00) \ &H100) And &HFF
ToChar = Bytes
End Function

Private Sub AdvanceLine()
RunningLine_ = RunningLine_ + 1
PreviousColumn_ = RunningColumn_
RunningColumn_ = 1
End Sub

Private Sub UngetChar(ByVal Character As String)
Dim Pos As Long
Dim Length As Long

Length = SizeOf(vbInteger)
If Character = vbBack Then Length = (Length + Len(vbNewLine)) * 2

Pos = Seek(File_)
Seek #File_, Pos - Length

Select Case Character
Case vbLf, vbBack
RunningLine_ = RunningLine_ - 1
RunningColumn_ = PreviousColumn_
End Select

RunningColumn_ = RunningColumn_ - IIf(Character = vbBack, 2, 1)
End Sub

Private Sub Fail(ByVal Msg As String)
Err.Raise vbObjectError + 13, "Scanner", FilePath_ & "(" & RunningLine_ & ", " & FrozenColumn_ & ") " & Msg
End Sub

Private Function ReadIdentifier(ByVal CodePoint As Integer)
Const MAX_LENGTH = 255
Dim IsOK As Boolean
Dim Cp As Integer
Dim Count As Integer
Dim Index As Long
Dim Name As String
Dim Ch As String * 1
Dim Suffix As String * 1
Dim Buffer As String * MAX_LENGTH
Dim Result As Token

Count = 1
Mid$(Buffer, Count, 1) = ChrW(CodePoint)

Do While Not AtEnd
Cp = GetCodePoint
Ch = ToChar(Cp)

IsOK = Ch = "_"
If Not IsOK Then IsOK = Ch >= "0" And Ch <= "9"
If Not IsOK Then IsOK = IsLetter(Cp)
If Not IsOK Then IsOK = IsSurrogate(Cp)
If Not IsOK Then Exit Do

Count = Count + 1
If Count > MAX_LENGTH Then Fail "Identifier too long"
Mid$(Buffer, Count, 1) = Ch
Loop

Select Case Ch
Case "%", "&", "^", "@", "!", "#", "$"
Suffix = Ch

Case Else
UngetChar Ch
End Select

Set Result = NewToken(tkIdentifier, Suffix:=Suffix)

Name = Left$(Buffer, Count)
Index = Keywords_.IndexOf(Name)

If Index <> 0 Then
Result.Kind = tkKeyword
Else
Index = Operators_.IndexOf(Name)

If Index <> 0 Then
Result.Kind = tkOperator
Else
Index = Contextuals_.IndexOf(Name)

If Index <> 0 Then
Index = Index + Keywords_.Count
Else
Index = Ids_.IndexOf(Name)

If Index = 0 Then
Ids_.Add Name, Name
Index = Ids_.Count
End If

Index = Index + Keywords_.Count + Contextuals_.Count
End If
End If
End If

Select Case Result.Kind
Case tkKeyword, tkOperator
If Result.Suffix <> vbNullChar Then Fail "Keyword or operator cannot have type-declaration character"
End Select

Result.Code = Index
Set ReadIdentifier = Result
End Function

Private Function ReadEscapedIdentifier() As Token
Const MAX_LENGTH = 255
Dim Cp As Integer
Dim Count As Integer
Dim Name As String
Dim Suffix As String * 1
Dim Buffer As String * MAX_LENGTH
Dim Token As Token

Do While Not AtEnd
Cp = GetCodePoint
If Cp = AscW("]") Then Exit Do
If Cp = 10 Then Fail "Invalid identifier"

Count = Count + 1
If Count > MAX_LENGTH Then Fail "Identifier too long"
Mid$(Buffer, Count, 1) = ToChar(Cp)
Loop

If Not AtEnd Then
Suffix = GetChar

Select Case Suffix
Case "%", "&", "^", "@", "!", "#", "$"
' OK

Case Else
UngetChar Suffix
Suffix = vbNullChar
End Select
End If

Set Token = NewToken(tkEscapedIdentifier, Suffix:=Suffix)
Name = Left$(Buffer, Count)
Token.Code = NameBank.Ids.IndexOf(Name)

If Token.Code = 0 Then
NameBank.Ids.Add Name, Name
Token.Code = NameBank.Ids.Count
End If

Set ReadEscapedIdentifier = Token
End Function

Private Function ReadString() As Token
Const MAX_LENGTH = 1013
Dim Count As Integer
Dim Ch As String * 1
Dim Buffer As String * MAX_LENGTH

Do
If Count = MAX_LENGTH Then Fail "String too long"

If AtEnd Then
Ch = vbLf
Else
Ch = GetChar
End If

Select Case Ch
Case """"
If AtEnd Then Exit Do
Ch = GetChar

If Ch = """" Then
Count = Append(Count, Buffer, Ch)
Else
' We read too much. Let's put it "back".
UngetChar Ch
Exit Do
End If

Case vbLf
Fail "Unclosed string"

Case Else
Count = Append(Count, Buffer, Ch)
End Select
Loop

Set ReadString = NewToken(tkString, , Left$(Buffer, Count))
End Function

Private Function Append(ByVal Count As Integer, ByRef Buffer As String, ByVal Ch As String) As Integer
Count = Count + 1
Mid$(Buffer, Count, 1) = Ch
Append = Count
End Function

Private Function ReadInteger(Optional ByVal FirstDigit As String) As Token
Const MAX_LENGTH = 29
Dim Cp As Integer
Dim Count As Integer
Dim Ch As String * 1
Dim Suffix As String * 1
Dim Buffer As String * MAX_LENGTH

If FirstDigit >= "0" And FirstDigit <= "9" Then
Count = 1
Mid$(Buffer, Count, 1) = FirstDigit
End If

Do Until AtEnd
If Count = MAX_LENGTH Then Fail "Literal too long"
Cp = GetCodePoint
Ch = ToChar(Cp)

Select Case Ch
Case "0" To "9"
Count = Count + 1
Mid$(Buffer, Count, 1) = Ch

Case "%", "&", "^", "@", "!", "#"
Suffix = Ch
Exit Do

Case "_"
' We'll ignore it

Case Else
UngetChar Ch
Exit Do
End Select
Loop

Set ReadInteger = NewToken(tkIntegerNumber, , Left$(Buffer, Count), Suffix)
End Function

Private Function ReadFloat(ByVal FirstDigit As String) As Token
Dim Ch As String * 1
Dim Result As Token
Dim FracPart As Token

Set Result = ReadInteger(FirstDigit:=FirstDigit)

If Result.Suffix = vbNullChar Then
If Not AtEnd Then
Ch = GetChar

If Ch = "." Then
Set FracPart = ReadInteger
If FracPart.Text = "" Then Fail "Invalid literal"
Result.Text = Result.Text & "." & FracPart.Text
Result.Kind = tkFloatNumber
Result.Suffix = FracPart.Suffix
Else
UngetChar Ch
End If
End If
End If

Set ReadFloat = Result
End Function

Private Function ReadNumber(ByVal FirstDigit As String) As Token
Dim Ch As String * 1
Dim Sg As String * 1
Dim Result As Token
Dim ExpPart As Token

Set Result = ReadFloat(FirstDigit)

If Result.Suffix = vbNullChar Then
If Not AtEnd Then
Ch = GetChar

Select Case Ch
Case "e", "E"
If AtEnd Then
UngetChar Ch
Else
Sg = GetChar

If Sg = "-" Or Sg = "+" Then
Ch = ""
Else
Ch = Sg
Sg = "+"
End If

Set ExpPart = ReadInteger(FirstDigit:=Ch)
If ExpPart.Text = "" Or ExpPart.Suffix <> vbNullChar Then Fail "Invalid literal"
Result.Text = Result.Text & "E" & Sg & ExpPart.Text
Result.Kind = tkSciNumber
End If

Case Else
UngetChar Ch
End Select
End If
End If

Set ReadNumber = Result
End Function

Private Function ReadAmpersand() As Token
Dim Ch As String * 1
Dim Token As Token

Ch = GetChar

Select Case Ch
Case "b", "B"
Set Token = ReadBin

Case "o", "O"
Set Token = ReadOctal

Case "h", "H"
Set Token = ReadHexa

Case "="
Set Token = NewToken(tkOperator, opCompConcat)

Case Else
UngetChar Ch
Set Token = NewToken(tkOperator, opConcat)
End Select

Set ReadAmpersand = Token
End Function

Private Function ReadBin() As Token
Const MAX_LENGTH = 96
Dim Count As Integer
Dim Ch As String * 1
Dim Suffix As String * 1
Dim Buffer As String * MAX_LENGTH

Do While Not AtEnd
If Count = MAX_LENGTH Then Fail "Literal too long"
Ch = GetChar

Select Case Ch
Case "0", "1"
Count = Count + 1
Mid$(Buffer, Count, 1) = Ch

Case "%", "&", "^", "@", "!", "#"
Suffix = Ch
Exit Do

Case "_"
' We'll ignore it

Case Else
UngetChar Ch
Exit Do
End Select
Loop

If Count = 0 Then Fail "Invalid literal"
Set ReadBin = NewToken(tkBinaryNumber, , Left$(Buffer, Count), Suffix)
End Function

Private Function ReadOctal()
Const MAX_LENGTH = 32
Dim Count As Integer
Dim Ch As String * 1
Dim Suffix As String * 1
Dim Buffer As String * MAX_LENGTH

Do While Not AtEnd
If Count = MAX_LENGTH Then Fail "Literal too long"
Ch = GetChar

Select Case Ch
Case "0" To "7"
Count = Count + 1
Mid$(Buffer, Count, 1) = Ch

Case "%", "&", "^", "@", "!", "#"
Suffix = Ch
Exit Do

Case "_"
' We'll ignore it

Case Else
UngetChar Ch
Exit Do
End Select
Loop

If Count = 0 Then Fail "Invalid literal"
Set ReadOctal = NewToken(tkOctalNumber, , Left$(Buffer, Count), Suffix)
End Function

Private Function ReadHexa() As Token
Const MAX_LENGTH = 24
Dim Count As Integer
Dim Ch As String * 1
Dim Suffix As String * 1
Dim Buffer As String * MAX_LENGTH

Do While Not AtEnd
If Count = MAX_LENGTH Then Fail "Literal too long"
Ch = GetChar

Select Case Ch
Case "0" To "9", "a" To "f", "A" To "F"
Count = Count + 1
Mid$(Buffer, Count, 1) = Ch

Case "%", "&", "^", "@", "!", "#"
Suffix = Ch
Exit Do

Case "_"
' We'll ignore it

Case Else
UngetChar Ch
Exit Do
End Select
Loop

If Count = 0 Then Fail "Invalid literal"
Set ReadHexa = NewToken(tkHexaNumber, , Left$(Buffer, Count), Suffix)
End Function

Private Function ReadHash() As Token
Const Msg = "Invalid literal"
Dim Cp As Integer
Dim Number As Integer
Dim Name As String
Dim Ch As String * 1
Dim Token As Token

' Let's get the first number.
Set Token = ReadInteger

If Token.Text = "" Then
' Maybe we have a month name?
Name = ReadMonthName

Select Case UCase$(Name)
Case UCase$(vIf), UCase$(vElseIf), UCase$(vElse), UCase$(vEnd), UCase$(vConst)
' Not a month name, we have a compiler directive instead.
Set ReadHash = NewToken(tkDirective, Text:=Name)
Exit Function

Case ""
Fail Msg

Case Else
Number = ConvertNameToNumber(Name)

If Number = 0 Then
' Not a month name, we have a variable file-handle instead.
' Hopefully this variable is not named Feb, for instance, otherwise we'll get tricked...
Set ReadHash = NewToken(tkFileHandle, Text:=Name)
Exit Function
End If

Token.Text = CStr(Number)
End Select
End If

' Let's get the first separator.
Cp = GetCodePoint
Ch = ToChar(Cp)

If IsLetter(Cp) Or Ch = "," Then
' We have a numeric file-handle
UngetChar Ch
Token.Kind = tkFileHandle
Set ReadHash = Token
Exit Function
End If

If Ch = ":" Then
' We are reading a time literal.
Name = ReadTime(Token.Text)

' Date literal must end with a '#'.
Ch = GetChar
If Ch <> "#" Then Fail Msg

Name = "1899-12-30 " & Name
Set ReadHash = NewToken(tkDateTime, Text:=Name)
Exit Function
End If

' We'll suppose it is a valid separator.
On Error Resume Next
Name = ReadDate(Token.Text, Ch)

If Err.Number Then
' It is not a date, but a numeric file handle
On Error GoTo 0
UngetChar Ch
Token.Kind = tkFileHandle
Set ReadHash = Token
Exit Function
End If

On Error GoTo 0
Ch = GetChar

Select Case Ch
Case " "
' We may have a date and time literal together.
Set ReadHash = NewToken(tkDateTime, Text:=ReadTime)
If ReadHash.Text = "" Then Fail Msg
ReadHash.Text = Name & " " & ReadHash.Text

Ch = GetChar
If Ch <> "#" Then Fail Msg

Case "#"
' Literal does not have a time part. Let's add it.
Set ReadHash = NewToken(tkDateTime, Text:=Name & " 00:00:00")

Case Else
Fail Msg
End Select
End Function

Private Function ReadDate(ByVal FirstNumber As String, ByVal Separator As String) As String
Const Msg = "Invalid literal"
Dim YYYY As Integer
Dim MM As Integer
Dim DD As Integer
Dim Result As String
Dim SecondNumber As Token
Dim ThirdNumber As Token
Dim Ch As String * 1

Set SecondNumber = ReadInteger
If SecondNumber.Text = "" Then Fail Msg

' The next separator must match the first one.
Ch = GetChar
If Ch <> Separator Then Fail Msg

Set ThirdNumber = ReadInteger
If ThirdNumber.Text = "" Then Fail Msg

If CInt(FirstNumber) >= 100 And Separator = "-" Then
YYYY = CInt(FirstNumber)
MM = CInt(SecondNumber.Text)
DD = CInt(ThirdNumber.Text)
Else
MM = CInt(FirstNumber)
DD = CInt(SecondNumber.Text)
YYYY = CInt(ThirdNumber.Text)

If YYYY < 100 Then
YYYY = YYYY + 1900
If YYYY < 1950 Then YYYY = YYYY + 100
End If
End If

' Validate year.
If YYYY > 9999 Then Fail Msg

' Validate month.
If MM < 1 Or MM > 12 Then Fail Msg

' Validate day.
Select Case MM
Case 4, 6, 9, 11
If DD > 30 Then Fail Msg

Case 2
If YYYY Mod 4 = 0 And YYYY Mod 100 <> 0 Or YYYY Mod 400 = 0 Then
If DD > 29 Then Fail Msg
Else
If DD > 28 Then Fail Msg
End If

Case Else
If DD > 31 Then Fail Msg
End Select

' Put it together in YYYY-MM-DD format.
If YYYY < 1000 Then Result = "0"
If YYYY < 100 Then Result = Result & "0"
If YYYY < 10 Then Result = Result & "0"
Result = Result & CStr(YYYY)
Result = Result & "-"

If MM < 10 Then Result = Result & "0"
Result = Result & CStr(MM)
Result = Result & "-"

If DD < 10 Then Result = Result & "0"
Result = Result & CStr(DD)

ReadDate = Result
End Function

Private Function ReadTime(Optional ByVal FirstNumber As String) As String
Const Msg = "Invalid literal"
Dim HH As Integer
Dim NN As Integer
Dim SS As Integer
Dim Number As String
Dim Ch As String * 1
Dim Ch2 As String * 1
Dim AP As String * 1

On Error GoTo GoneWrong
HH = CInt(FirstNumber)
Number = ReadInteger
If Number = "" Then Err.Raise 0
NN = CInt(Number)

Ch = GetChar

If Ch = ":" Then
Number = ReadInteger
If Number = "" Then Err.Raise 0
SS = CInt(Number)
Else
UngetChar Ch
End If

If Not AtEnd Then
Ch = GetChar

If Ch = " " Then
If Not AtEnd Then
Ch = GetChar

If Ch = "a" Or Ch = "A" Then
Ch2 = GetChar

If Ch2 = "m" Or Ch2 = "M" Then
AP = "A"
Else
UngetChar Ch2
UngetChar Ch
UngetChar " "
End If

ElseIf Ch = "p" Or Ch = "P" Then
Ch2 = GetChar

If Ch2 = "m" Or Ch2 = "M" Then
AP = "P"
Else
UngetChar Ch2
UngetChar Ch
UngetChar " "
End If

Else
UngetChar Ch
UngetChar " "
End If
End If
Else
UngetChar Ch
End If
End If

' Validate hour, minute, and second.
If HH < 0 Or HH > 23 Then Err.Raise 0
If NN < 0 Or NN > 59 Then Err.Raise 0
If SS < 0 Or SS > 59 Then Err.Raise 0

If AP = "A" Then
If HH = 12 Then HH = 0

ElseIf AP = "P" Then
If HH <> 12 Then HH = HH + 12
End If

' Put it together in HH:NN:SS format.
Number = CStr(SS)
If SS < 10 Then Number = "0" & Number
Number = ":" & Number

Number = CStr(NN) & Number
If NN < 10 Then Number = "0" & Number

Number = ":" & Number
Number = CStr(HH) & Number
If HH < 10 Then Number = "0" & Number

ReadTime = Number
Exit Function

GoneWrong:
Fail Msg
End Function

Private Function ReadMonthName() As String
Dim Result As String
Dim Ch As String * 1
Dim Prv As String * 1

Do While Not AtEnd
Prv = Ch
Ch = GetChar

Select Case Ch
Case "#", vbLf, ",", ";", ")", " "
UngetChar Ch
Exit Do

Case "0" To "9"
' We safely can assume we read two characters more than needed.
UngetChar Ch
UngetChar Prv
Result = Left$(Result, Len(Result) - 1)
Exit Do

Case Else
Result = Result & Ch
End Select
Loop

ReadMonthName = Result
End Function

Private Function ConvertNameToNumber(ByVal Name As String) As Integer
Dim Count As Integer
Dim Result As Integer
Dim MonthName As Variant
Static MonthNames As Variant

If IsEmpty(MonthNames) Then
MonthNames = Array("January", "February", "March", "April", "May", "June", _
"July", "August", "September", "October", "November", "December")
End If

For Each MonthName In MonthNames
Count = Count + 1

If StrComp(Name, MonthName, vbTextCompare) = 0 Then Result = Count
If Result = 0 Then: If StrComp(Name, Left$(MonthName, 3), vbTextCompare) = 0 Then Result = Count
If Result <> 0 Then Exit For
Next

ConvertNameToNumber = Result
End Function

Private Function IsSpace(ByVal CodePoint As Long) As Boolean
Const NULL_CHAR = 0
Const VERTICAL_TAB = 9
Const EOM = 25
Const WHITE_SPACE = 32
Const NO_BREAK_SPACE = 160
Const OGHAM_SPACE_MARK = &H1680
Const MONGOLIAN_VOWEL_SEPARATOR = &H180E
Const EN_QUAD = &H2000
Const HAIR_SPACE = &H200A
Const NARROW_NO_BREAK_SPACE = &H202F
Const MEDIUM_MATHEMATICAL_SPACE = &H205F
Const IDEOGRAPHIC_SPACE = &H3000

Select Case CodePoint
Case NULL_CHAR, WHITE_SPACE, VERTICAL_TAB, EOM, NO_BREAK_SPACE, OGHAM_SPACE_MARK, MONGOLIAN_VOWEL_SEPARATOR, _
NARROW_NO_BREAK_SPACE, MEDIUM_MATHEMATICAL_SPACE, IDEOGRAPHIC_SPACE, EN_QUAD To HAIR_SPACE
IsSpace = True
End Select
End Function

Private Function NewToken( _
ByVal Kind As TokenKind, _
Optional Code As Long, _
Optional ByVal Text As String, _
Optional ByVal Suffix As String = vbNullChar _
) As Token
Set NewToken = New Token

With NewToken
.Text = Text
.Code = Code
.Kind = Kind
.Suffix = Suffix
.Line = RunningLine_
.Column = FrozenColumn_
End With
End Function

Private Function ReadComment(Optional ByVal IsRem As Boolean) As Token
Const MAX_LENGTH = 1013
Dim Count As Integer
Dim Ch As String * 1
Dim Buffer As String * MAX_LENGTH
Dim Text As String

If IsRem Then
Text = vRem & " "
Else
Text = "' "
End If

Count = Len(Text)
Mid$(Buffer, 1, Count) = Text

Do While Not AtEnd
If Count = MAX_LENGTH Then Fail "Comment too long"
Ch = GetChar
If Ch = vbLf Then Exit Do

Count = Count + 1
Mid$(Buffer, Count, 1) = Ch
Loop

Set ReadComment = NewToken(tkComment, Text:=Left$(Buffer, Count))
End Function

Private Sub DiscardComment()
Dim Count As Long
Dim Ch As String * 1
Count = 1

Do While Not AtEnd
Ch = GetChar

Select Case Ch
Case "`"
Count = Count + 1

Case "ยด"
Count = Count - 1
If Count = 0 Then Exit Do
End Select
Loop
End Sub
End Class

Public Class SourceFile
Option Explicit

Public Path As String
Public Entities As New KeyedList
End Class

Public Class Token
Option Explicit

Public Enum TokenKind
tkWhiteSpace
tkComment
tkIdentifier
tkEscapedIdentifier
tkKeyword
tkIntegerNumber
tkFloatNumber
tkSciNumber
tkBinaryNumber
tkOctalNumber
tkHexaNumber
tkFileHandle
tkString
tkDateTime
tkOperator
tkLeftParenthesis
tkRightParenthesis
tkHardLineBreak
tkSoftLineBreak
tkLineContinuation
tkListSeparator
tkPrintSeparator
tkDirective
tkEndOfStream
End Enum

Public Text As String
Public Suffix As String
Public Kind As TokenKind
Public Line As Long
Public Column As Long
Public Spaces As Long
Public Code As Long

Private Sub Class_Initialize()
Text = " "
Suffix = vbNullChar
End Sub
End Class

Public Class ConstConstruct
Option Explicit

Public Access As Accessibility
Public Id As Identifier
Public DataType As DataType
Public Value As Token
End Class

Public Class DataType
Option Explicit

Public Id As Identifier
Public IsArray As Boolean
Public FixedLength As Token
End Class

Public Class DeclareConstruct
Option Explicit

Private Parms_ As KeyedList

Public Access As Accessibility
Public IsSub As Boolean
Public Id As Identifier
Public IsCDecl As Boolean
Public LibName As Token
Public AliasName As Token
Public DataType As DataType

Private Sub Class_Initialize()
Set Parms_ = New KeyedList
Parms_.CompareMode = vbTextCompare
End Sub

Public Property Get Parameters() As KeyedList
Set Parameters = Parms_
End Property
End Class

Public Class Deftype
Option Explicit
Const LAST_INDEX = 25

Private A_Z_ As Boolean
Private Letters_(0 To LAST_INDEX) As Token

Public Default Property Get Item(ByVal Letter As String) As DataType
Static DfType As Token
Dim Index As Integer

If DfType Is Nothing Then
Set DfType = New Token
DfType.Kind = tkKeyword
DfType.Code = kwVariant
End If

Index = ToIndex(Letter)

If A_Z_ Then
Set Item = Letters_(0)

ElseIf Index = -1 Or Letters_(Index) Is Nothing Then
Set Item = NewDataType(DfType)

Else
Set Item = NewDataType(Letters_(Index))
End If
End Property

Public Sub SetRange(ByVal FirstLetter As String, ByVal LastLetter As String, ByVal VariableType As Integer)
Dim First As Integer
Dim Last As Integer
Dim Letter As Integer
Dim Token As Token

First = ToIndex(FirstLetter)
Last = ToIndex(LastLetter)

If First > Last Then
Letter = First
First = Last
Last = Letter
End If

A_Z_ = First = 0 And Last = LAST_INDEX

Set Token = New Token
Token.Kind = tkKeyword

Select Case VariableType
Case vbBoolean
Token.Code = kwBoolean

Case vbByte
Token.Code = kwByte

Case vbInteger
Token.Code = kwInteger

Case vbLong
Token.Code = kwLong

Case vbLongLong
Token.Code = kwLongLong

Case vbLongPtr
Token.Code = kwLongPtr

Case vbCurrency
Token.Code = kwCurrency

Case vbDecimal
Token.Code = cxDecimal

Case vbSingle
Token.Code = kwSingle

Case vbDouble
Token.Code = kwDouble

Case vbDate
Token.Code = kwDate

Case vbString
Token.Code = kwString

Case vbObject
Token.Code = cxObject

Case vbVariant
Token.Code = kwVariant

Case Else
Debug.Assert False
End Select

For Letter = First To Last
If Not Letters_(Letter) Is Nothing Then
If Letters_(Letter).Text <> Token.Text Then Err.Raise 0
End If

Set Letters_(Letter) = Token
Next
End Sub

Private Function ToIndex(ByVal Letter As String) As Integer
Const CAPITAL_A = 65
Const CAPITAL_Z = 90
Const SMALL_A = 97
Dim Result As Integer

Debug.Assert Letter <> ""

Result = AscW(Left$(Letter, 1))
If Result >= SMALL_A Then Result = Result - SMALL_A + CAPITAL_A
If Result < CAPITAL_A Or Result > CAPITAL_Z Then Result = CAPITAL_A - 1
Result = Result - CAPITAL_A
ToIndex = Result
End Function
End Class

Public Class Entity
Option Explicit

Private Consts_ As KeyedList
Private Enums_ As KeyedList
Private Declares_ As KeyedList
Private Events_ As KeyedList

Public IsClass As Boolean
Public Accessibility As Accessibility
Public Id As Identifier

Public OptionBase As Integer
Public OptionCompare As VbCompareMethod
Public OptionExplicit As Boolean

Private Sub Class_Initialize()
Set Consts_ = New KeyedList
Consts_.CompareMode = vbTextCompare

Set Enums_ = New KeyedList
Enums_.CompareMode = vbTextCompare

Set Declares_ = New KeyedList
Declares_.CompareMode = vbTextCompare

Set Events_ = New KeyedList
Events_.CompareMode = vbTextCompare
End Sub

Public Property Get Consts() As KeyedList
Set Consts = Consts_
End Property

Public Property Get Enums() As KeyedList
Set Enums = Enums_
End Property

Public Property Get Declares() As KeyedList
Set Declares = Declares_
End Property

Public Property Get Events() As KeyedList
Set Events = Events_
End Property

Public Static Property Get DefTypes() As Deftype
Dim Hidden As New Deftype

Set DefTypes = Hidden
End Property
End Class

Public Class EnumConstruct
Option Explicit

Private Enumerands_ As KeyedList

Public Access As Accessibility
Public Id As Identifier

Private Sub Class_Initialize()
Set Enumerands_ = New KeyedList
Enumerands_.CompareMode = vbTextCompare
End Sub

Public Property Get Enumerands() As KeyedList
Set Enumerands = Enumerands_
End Property
End Class

Public Class EnumerandConstruct
Option Explicit

Public Access As Accessibility
Public Id As Identifier
Public Value As Token
End Class

Public Class EventConstruct
Option Explicit

Private Parms_ As KeyedList

Public Id As Identifier

Private Sub Class_Initialize()
Set Parms_ = New KeyedList
Parms_.CompareMode = vbTextCompare
End Sub

Public Property Get Access() As Accessibility
Access = AccessPublic
End Property

Public Property Get Parameters() As KeyedList
Set Parameters = Parms_
End Property
End Class

Public Class Identifier
Option Explicit

Private Name_ As Token
Private Project_ As Token

Public Property Get Name() As Token
Set Name = Name_
End Property

Public Property Set Name(ByVal Value As Token)
If Not Name_ Is Nothing Then Set Project_ = Name_
Set Name_ = Value
End Property

Public Property Get Project() As Token
Set Project = Project_
End Property
End Class

Public Class Parameter
Option Explicit

Public Index As Integer
Public IsOptional As Boolean
Public IsByVal As Boolean
Public IsParamArray As Boolean
Public Id As Identifier
Public IsArray As Boolean
Public DataType As DataType
Public Init As Token
End Class

Public Class Parser
Option Explicit
Option Compare Binary

Public Enum Accessibility
AccessLocal
AccessPublic
AccessPrivate
AccessFriend
End Enum

Public Enum SignatureKind
SubKind = 1
FunctionKind
PropertyGetKind
PropertyLetKind
PropertySetKind
DeclareKind
EventKind
TupleKind
End Enum

Private Enum NarrowContext
NoContext
OptionContext
OptionCompareContext
OnContext
DeclareContext
DeclareLibContext
DeclareAliasContext
ForNextContext
ForToContext
[Next Keyword Is For]
[Next Keyword Is Input | Next Identifier Is Append, Binary, Output, or Random]
[Next Keyword Is As or Shared | Next Identifier Is Access]
[Next Keyword Is Access/Write | Next Identifier Is Access/Read]
[Next Keyword Is Access/Write, Lock, As, or Shared]
[Next Keyword Is Lock, As, or Shared]
[Next Keyword Is Lock/Write | Next Identifier Is Lock/Read]
[Next Keyword Is Lock/Write or As]
[Next Keyword Is As]
[Next Token Is Filehandle]
[Next Identifier Is Len]
End Enum

Private Downgrade_ As Boolean
Private WasAs_ As Boolean
Private LastToken_ As Token
Private LookAhead_ As Token
Private Scanner_ As Scanner
Private Source_ As SourceFile
Private State_ As NarrowContext

Private Sub Class_Initialize()
Set Scanner_ = New Scanner
End Sub

' Callers *must* pass a SourceFile before calling Parse method.
Friend Property Set SourceFile(ByVal Source As SourceFile)
Debug.Assert Not Source Is Nothing

Set Scanner_ = New Scanner
Set Source_ = Source
Scanner_.OpenFile Source_.Path

Downgrade_ = False
WasAs_ = False
Set LastToken_ = New Token
State_ = NoContext
Set LookAhead_ = Nothing
End Property

Public Property Get Scanner()
Set Scanner = Scanner_
End Property

' * Marks [Access], [Alias], [Append], [Base], [Binary], [Compare], [Error], [Explicit], [Lib], [Line], [Name], [Output],
' [PtrSafe], [Random], [Read], [Reset], [Step], [Text], and [Width] as keywords according to their context.
'
' * Turns unary [.] and [!] into [~.] and [~!] respectively.
'
' * Changes keywords after [.] or [!] into regular identifiers.
'
' * Downgrades [String] and [Date] to regular identifiers when used as functions.
Public Function NextToken() As Token
Dim Upgrade As Boolean
Dim Revoke As Boolean
Dim Token As Token
Dim LastToken As Token
Dim Done As Boolean
Dim Spaces As Long

Do
Done = True

If LookAhead_ Is Nothing Then
Set Token = Scanner_.GetToken
Else
Set Token = LookAhead_
Set LookAhead_ = Nothing
End If

If IsEndOfContext(Token) Then
State_ = NoContext
Else
Select Case Token.Kind
Case tkOperator
WasAs_ = False
Downgrade_ = Token.Code = opDot Or Token.Code = opBang

If Spaces <> 0 Then
If Token.Code = opDot Then
Token.Code = opWithDot
ElseIf Token.Code = opBang Then
Token.Code = opWithBang
End If
End If

Case tkKeyword
If Downgrade_ Then
Downgrade_ = False
Token.Kind = tkIdentifier
Token.Code = 0

Else
Select Case Token.Code
Case kwAs
WasAs_ = True

Select Case State_
Case [Next Keyword Is As or Shared | Next Identifier Is Access], _
[Next Keyword Is Access/Write, Lock, As, or Shared], _
[Next Keyword Is Lock, As, or Shared], _
[Next Keyword Is Lock/Write or As], _
[Next Keyword Is As]
State_ = [Next Token Is Filehandle]
End Select

Case kwDate, kwString
If Not WasAs_ Then Token.Kind = tkIdentifier

Case kwDeclare
If State_ = NoContext Then State_ = DeclareContext

Case kwFor
If State_ = NoContext Then
State_ = ForNextContext

ElseIf State_ = [Next Keyword Is For] Then
State_ = [Next Keyword Is Input | Next Identifier Is Append, Binary, Output, or Random]
End If

Case kwInput
If State_ = [Next Keyword Is Input | Next Identifier Is Append, Binary, Output, or Random] Then
State_ = [Next Keyword Is As or Shared | Next Identifier Is Access]
End If

Case cxLock
Select Case State_
Case [Next Keyword Is Access/Write, Lock, As, or Shared], _
[Next Keyword Is Lock, As, or Shared]
State_ = [Next Keyword Is Lock/Write | Next Identifier Is Lock/Read]
End Select

Case kwOpen
If State_ = NoContext Then State_ = [Next Keyword Is For]

Case kwOption
If State_ = NoContext Then State_ = OptionContext

Case kwOn
If State_ = NoContext Then State_ = OnContext

Case cxShared
Select Case State_
Case [Next Keyword Is As or Shared | Next Identifier Is Access], _
[Next Keyword Is Access/Write | Next Identifier Is Access/Read], _
[Next Keyword Is Lock, As, or Shared]
State_ = [Next Keyword Is As]
End Select

Case kwTo
If State_ = ForNextContext Then State_ = ForToContext

Case kwWrite
Select Case State_
Case [Next Keyword Is Access/Write | Next Identifier Is Access/Read], _
[Next Keyword Is Access/Write, Lock, As, or Shared]
State_ = [Next Keyword Is Lock, As, or Shared]

Case [Next Keyword Is Lock/Write | Next Identifier Is Lock/Read], _
[Next Keyword Is Lock/Write or As]
State_ = [Next Keyword Is As]
End Select
End Select
End If

Case tkIdentifier
Downgrade_ = False
WasAs_ = False

Select Case State_
Case NoContext
Select Case Token.Code
Case cxLine
Set LookAhead_ = Scanner_.GetToken
Upgrade = LookAhead_.Kind = tkKeyword And LookAhead_.Code = kwInput

Case cxName, cxReset
Upgrade = LastToken_.Kind <> tkKeyword Or LastToken_.Code <> kwCall

If Upgrade Then
Set LastToken = LastToken_
Set LastToken = Token
Set LookAhead_ = NextToken()
Set LastToken_ = LastToken

Select Case LookAhead_.Code
Case opCompAnd, opCompEqv, opCompImp, opCompMod, opCompOr, opCompXor, _
opCompSum, opCompSubt, opCompMul, opCompDiv, opCompIntDiv, opCompPow, _
opCompLSh, opCompRSh, opCompURSh, opCompConcat, opDot, opBang
Upgrade = False

Case Else
Upgrade = True
End Select

If Upgrade Then Upgrade = LookAhead_.Kind <> tkKeyword Or _
LookAhead_.Code <> kwAs

If Upgrade Then Upgrade = LookAhead_.Kind <> tkOperator
If Upgrade Then Upgrade = LookAhead_.Kind <> tkLeftParenthesis
If Upgrade Then Upgrade = Not IsEndOfContext(LookAhead_)
End If

Case cxWidth
Set LookAhead_ = Scanner_.GetToken
Upgrade = LookAhead_.Kind = tkFileHandle
End Select

Case OptionContext
Upgrade = Token.Code = cxBase
If Not Upgrade Then Upgrade = Token.Code = cxExplicit

If Not Upgrade Then
Upgrade = Token.Code = cxCompare
If Upgrade Then State_ = OptionCompareContext
End If

Case OptionCompareContext
Upgrade = Token.Code = cxBinary
If Not Upgrade Then Upgrade = Token.Code = cxText

Case DeclareContext
Upgrade = Token.Code = kwPtrSafe

If Upgrade Then
State_ = DeclareLibContext

ElseIf Not Upgrade Then
Upgrade = Token.Code = cxLib
If Upgrade Then State_ = DeclareAliasContext
End If

Case DeclareLibContext
Upgrade = Token.Code = cxLib
If Upgrade Then State_ = DeclareAliasContext

Case DeclareAliasContext
Upgrade = Token.Code = cxAlias
Revoke = True

Case ForToContext
Upgrade = Token.Code = cxStep
Revoke = True

Case OnContext
Upgrade = Token.Code = cxError
Revoke = True

Case [Next Keyword Is Input | Next Identifier Is Append, Binary, Output, or Random]
Upgrade = Token.Code = cxAppend
If Not Upgrade Then Upgrade = Token.Code = cxBinary
If Not Upgrade Then Upgrade = Token.Code = cxOutput
If Not Upgrade Then Upgrade = Token.Code = cxRandom
State_ = [Next Keyword Is As or Shared | Next Identifier Is Access]

Case [Next Keyword Is As or Shared | Next Identifier Is Access]
Upgrade = Token.Code = cxAccess
If Upgrade Then State_ = [Next Keyword Is Access/Write | Next Identifier Is Access/Read]

Case [Next Keyword Is Access/Write, Lock, As, or Shared], _
[Next Keyword Is Lock, As, or Shared]
Upgrade = Token.Code = cxShared
If Upgrade Then State_ = [Next Keyword Is As]

Case [Next Keyword Is Access/Write | Next Identifier Is Access/Read]
Upgrade = Token.Code = cxRead
If Upgrade Then State_ = [Next Keyword Is Access/Write, Lock, As, or Shared]

Case [Next Keyword Is Lock/Write | Next Identifier Is Lock/Read]
Upgrade = Token.Code = cxRead
If Upgrade Then State_ = [Next Keyword Is Lock/Write or As]

Case [Next Identifier Is Len]
Upgrade = Token.Code = cxLen
Revoke = True
End Select

Case tkFileHandle
If State_ = [Next Token Is Filehandle] Then State_ = [Next Identifier Is Len]

Case tkWhiteSpace
Done = False
Spaces = Spaces + 1

Case tkSoftLineBreak, tkHardLineBreak
WasAs_ = False
End Select

If Upgrade Then
Token.Kind = tkKeyword
If Token.Suffix <> vbNullChar Then Fail Token, Msg060
If Revoke Then State_ = NoContext
End If
End If

If Token.Kind <> tkWhiteSpace Then Set LastToken_ = Token
Loop While Not Done

If Token.Kind <> tkHardLineBreak And Token.Spaces = 0 Then Token.Spaces = Spaces
Set NextToken = Token
End Function

' Parses Source_'s content.
' Results are in Sources_' properties like Consts, Enums, etc.
Public Sub Parse(ByVal Source As SourceFile)
Dim Entity As Entity
Dim Token As Token

Set SourceFile = Source

Do
Set Entity = New Entity

Set Token = SkipLineBreaks
If Token.Kind = tkEndOfStream Then Exit Do

If IsKw(Token, kwPublic) Then
Entity.Accessibility = AccessPublic
Set Token = NextToken

ElseIf IsKw(Token, kwPrivate) Then
Entity.Accessibility = AccessPrivate
Set Token = NextToken
End If

If IsKw(Token, kwClass) Then
Entity.IsClass = True

ElseIf IsKw(Token, kwModule) Then
' Nothing to do.

ElseIf Entity.Accessibility = AccessLocal Then
Fail Token, Msg007, Msg001

Else
Fail Token, Msg007, Msg002
End If

If Entity.Accessibility = AccessLocal Then Entity.Accessibility = AccessPublic
Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, Msg007, Msg003

Set Entity.Id = NewId(Token)
MustEatLineBreak

Set Token = ParseDeclarationArea(Entity)
If Not IsKw(Token, kwEnd) Then Fail Token, Msg004, vEnd

Set Token = ParseProcedureArea(Entity)
If Not IsKw(Token, IIf(Entity.IsClass, kwClass, kwModule)) Then Fail Token, Msg004, Msg002

If Source_.Entities.Exists(NameOf(Entity.Id.Name)) Then Fail Entity.Id, Msg006 & NameOf(Entity.Id.Name)
Source_.Entities.AddKeyValue NameOf(Entity.Id.Name), Entity
MustEatLineBreak
Loop
End Sub

Private Function ParseDeclarationArea(ByVal Entity As Entity) As Token
Dim HadBase As Boolean
Dim HadCompare As Boolean
Dim Text As String
Dim Token As Token
Dim Access As Accessibility

Debug.Assert Not Entity Is Nothing

Do
Set Token = SkipLineBreaks

If Token.Kind = tkKeyword Then
Select Case Token.Code
Case kwOption
If Access <> AccessLocal Then Fail Token, Msg009, Msg003
Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail Token, Msg015, vOption

Select Case Token.Code
Case cxBase
If HadBase Then Fail Token, Msg010
HadBase = True

Set Token = NextToken
''' Remove heading zeros ''''
Text = Token.Text

Do
If Left$(Text, 1) <> "0" Then Exit Do
Text = Mid$(Text, 2)
Loop

If Text = "" Then Text = "0"
''''''''''''''''''''''''''''''

If Token.Kind <> tkIntegerNumber Or (Text <> "0" And Text <> "1") Then
Fail Token, Msg011, "0 or 1"
End If

Entity.OptionBase = IIf(Text = "0", 0, 1)

Case cxCompare
If HadCompare Then Fail Token, Msg010
HadCompare = True

Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail Token, Msg013, Msg014

Select Case Token.Code
Case cxBinary
Entity.OptionCompare = vbBinaryCompare

Case cxText
Entity.OptionCompare = vbTextCompare

Case Else
Fail Token, Msg013, Msg014
End Select

Case cxExplicit
If Entity.OptionExplicit Then Fail Token, Msg010
Entity.OptionExplicit = True

Case Else
Fail Token, Msg015, vOption
End Select

Case kwDefBool
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbBoolean, Entity

Case kwDefByte
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbByte, Entity

Case kwDefInt
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbInteger, Entity

Case kwDefLng
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbLong, Entity

Case kwDefLngLng
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbLongLong, Entity

Case kwDefLngPtr
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbLongPtr, Entity

Case kwDefCur
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbCurrency, Entity

Case kwDefDec
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbDecimal, Entity

Case kwDefSng
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbSingle, Entity

Case kwDefDbl
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbDouble, Entity

Case kwDefDate
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbDate, Entity

Case kwDefStr
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbString, Entity

Case kwDefObj
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbObject, Entity

Case kwDefVar
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
ParseDef vbVariant, Entity

Case kwPublic, kwGlobal
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
Access = AccessPublic

Case kwPrivate
If Access <> AccessLocal Then Fail Token, Msg008, Msg003
Access = AccessPrivate

Case kwConst
If Access = AccessLocal Then Access = AccessPrivate
ParseConsts Access, Entity
Access = AccessLocal

Case kwEnum
ParseEnum Access, Entity
Access = AccessLocal

Case kwDeclare
ParseDeclare Access, Entity
Access = AccessLocal

Case kwEvent
If Not Entity.IsClass Then Fail Token, Msg016
If Access = AccessLocal Then Access = AccessPublic
If Access <> AccessPublic Then Fail Token, Msg017
ParseEvent Entity
Access = AccessLocal

Case kwEnd
Exit Do

Case Else
Fail Token, Msg018
End Select

Else
Fail Token, Msg018
End If
Loop

Set ParseDeclarationArea = Token
End Function

Private Function ParseProcedureArea(ByVal Entity As Entity) As Token
Set ParseProcedureArea = NextToken
End Function

Private Sub ParseDef(ByVal VariableType As Integer, ByVal Entity As Entity)
Dim First As String
Dim Last As String
Dim Token As Token
Dim Mark As Token

Debug.Assert Not Entity Is Nothing
Do
Set Token = SkipLineBreaks
Set Mark = Token

If Token.Kind <> tkIdentifier Then Fail Token, Msg019, Msg020
If Token.Suffix <> vbNullChar Then Fail Token, Msg060

First = NameOf(Token)

Set Token = NextToken

If IsOp(Token, opSubt) Then
If Token.Kind <> tkIdentifier Or Token.Suffix <> vbNullChar Then Fail Token, Msg019, Msg021

Last = NameOf(Token)
Set Token = NextToken
Else
Last = First
End If

On Error Resume Next
Entity.DefTypes.SetRange First, Last, VariableType

If Err Then
On Error GoTo 0
Fail Token, Msg022
End If

On Error GoTo 0

If IsBreak(Token) Then Exit Do
If Token.Kind <> tkListSeparator Then Fail Token, Msg019, ","
Loop
End Sub

Private Sub ParseConsts(ByVal Access As Accessibility, ByVal Entity As Entity)
Dim Token As Token
Dim Cnt As ConstConstruct

Debug.Assert Not Entity Is Nothing

Do
' Get Const's name
Set Token = SkipLineBreaks
If Not IsProperId(Token) Then Fail Token, Msg023, Msg003

Set Cnt = New ConstConstruct
Cnt.Access = Access
Set Cnt.Id = NewId(Token)

Set Token = NextToken

' Do we have an As clause?
If IsKw(Token, kwAs) Then
If Token.Suffix <> vbNullChar Then Fail Token, Msg024

' Get Const's data type name
Set Token = NextToken

Select Case Token.Code
Case kwBoolean, kwByte, kwInteger, kwLong, kwLongLong, kwCurrency, cxDecimal, kwSingle, kwDouble, kwDate, _
kwString, kwLongPtr
' OK

Case Else
Fail Token, Msg023, Msg025
End Select

Set Cnt.DataType = NewDataType(Token)
Set Token = NextToken

If IsOp(Token, opMul) Then
If Cnt.DataType.Id.Name <> vString Then Fail Token, Msg026

Set Cnt.DataType.FixedLength = Token

Set Token = NextToken
End If

ElseIf Cnt.Id.Name.Suffix <> vbNullChar Then
' Assign DataType property based on type sufix
Set Cnt.DataType = FromChar(Cnt.Id.Name.Suffix)
End If

' Discard "="
If Not IsOp(Token, opEq) Then Fail Token, Msg023, "="

' Get Const's value
Set Token = GetExpression
Set Cnt.Value = Token

' Ensure it's not a duplicated Const
If Entity.Consts.Exists(NameOf(Cnt.Id.Name)) Then Fail Token, Msg006 & NameOf(Cnt.Id.Name)

If Cnt.DataType Is Nothing Then
' TODO: Infer its data type
End If

' Save it
Entity.Consts.AddKeyValue NameOf(Cnt.Id.Name), Cnt

' Move on
Set Token = NextToken
If IsBreak(Token) Then Exit Do
If Token.Kind <> tkListSeparator Then Fail Token, Msg023, Msg027
Loop
End Sub

Private Sub ParseEnum(ByVal Access As Accessibility, ByVal Entity As Entity)
Dim Token As Token
Dim Enm As EnumConstruct
Dim Emd As EnumerandConstruct
Dim Count As Long

Debug.Assert Not Entity Is Nothing

Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, Msg028, Msg003
If Token.Suffix <> vbNullChar Then Fail Token, Msg029

Set Enm = New EnumConstruct
If Access = AccessLocal Then Access = AccessPublic
Enm.Access = Access
Set Enm.Id = NewId(Token)

Set Token = NextToken
If Not IsBreak(Token) Then Fail Token, Msg030, Msg031

Do
Set Token = SkipLineBreaks
If IsKw(Token, kwEnd) Then Exit Do
If Not IsId(Token) Then Fail Token, Msg032, Msg003
If Token.Suffix <> vbNullChar Then Fail Token, Msg033

Set Emd = New EnumerandConstruct
Emd.Access = Access
Set Emd.Id = NewId(Token)

Set Token = NextToken

If IsOp(Token, opEq) Then
Set Token = NextToken
Set Emd.Value = GetExpression

Set Token = NextToken
Else
' TODO Deal when the previous enumerand has an assigned value
Set Emd.Value = New Token
Emd.Value.Kind = tkIntegerNumber
Emd.Value.Text = CStr(Count)
Emd.Value.Suffix = "&"
End If

If Enm.Enumerands.Exists(NameOf(Emd.Id.Name)) Then Fail Emd.Id, Msg006 & NameOf(Emd.Id.Name)

Enm.Enumerands.AddKeyValue NameOf(Emd.Id.Name), Emd
Count = Count + 1
Loop While IsBreak(Token)

If Not IsKw(Token, kwEnd) Then Fail Token, Msg034, vEnd

Set Token = NextToken
If Not IsKw(Token, kwEnum) Then Fail Token, Msg034, vEnum
MustEatLineBreak

If Enm.Enumerands.Count = 0 Then Fail Enm, Msg035
If Entity.Enums.Exists(NameOf(Enm.Id.Name)) Then Fail Enm.Id, Msg006 & NameOf(Enm.Id.Name)

Entity.Enums.AddKeyValue NameOf(Enm.Id.Name), Enm
End Sub

Private Sub ParseDeclare(ByVal Access As Accessibility, ByVal Entity As Entity)
Dim Token As Token
Dim Tkn As Token
Dim Dcl As DeclareConstruct
Debug.Assert Not Entity Is Nothing

Set Dcl = New DeclareConstruct
If Access = AccessLocal Then Access = AccessPublic
Dcl.Access = Access

' Is it PtrSafe?
Set Token = NextToken

If IsKw(Token, kwPtrSafe) Then
' Just ignore it
Set Token = NextToken
End If

' Is it a Sub or a Function?
If IsKw(Token, kwSub) Then
' It is a Sub
Dcl.IsSub = True

ElseIf IsKw(Token, kwFunction) Then
' It is a Function
Dcl.IsSub = False ' Technically this is not needed.

Else
' It is not a Sub nor a Function
Fail Token, Msg036, Msg037
End If

' Get its name.
Set Token = NextToken
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, Msg036, Msg003

Set Dcl.Id = NewId(Token)

' Maybe there is a CDecl?
Set Token = NextToken

If IsKw(Token, kwCDecl) Then
Dcl.IsCDecl = True
Set Token = NextToken
End If

' Discard Lib
If Not IsKw(Token, cxLib) Then Fail Token, Msg036, vLib

' Get Lib's name
Set Token = NextToken
If Token.Kind <> tkString Then Fail Token, Msg036, Msg038
Set Dcl.LibName = Token

' Maybe there is an Alias?
Set Token = NextToken

If IsKw(Token, cxAlias) Then
' Get Alias' name
Set Token = NextToken
If Token.Kind <> tkString Then Fail Token, Msg036, Msg039

Set Dcl.AliasName = Token
Set Token = NextToken
End If

' Get its parameters.
If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Entity, DeclareKind, Dcl.Parameters)

' Maybe there's an "As" clause?
If IsKw(Token, kwAs) Then
' Can we have an "As" clause?
If Dcl.IsSub Then Fail Token, Msg036, Msg031
If Token.Suffix <> vbNullChar Then Fail Token, Msg024

' Get data type name
Set Token = NextToken

Select Case Token.Kind
Case tkIdentifier, tkEscapedIdentifier
If Token.Suffix <> vbNullChar Then Fail Token, Msg060
Set Dcl.DataType = NewDataType(Token)
Set Token = NextToken

If IsOp(Token, opDot) Then
Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, Msg036, Msg025

Set Dcl.DataType.Id.Name = Token
Set Token = NextToken
End If

Case tkKeyword
Select Case Token.Code
Case kwBoolean, kwByte, kwInteger, kwLong, kwLongLong, kwCurrency, cxDecimal, kwSingle, kwDouble, _
kwDate, kwString, kwLongPtr
Set Dcl.DataType = NewDataType(Token)
Set Token = NextToken

Case Else
Fail Token, Msg036, Msg025
End Select

Case Else
Fail Token, Msg036, Msg025
End Select

' Maybe it returns an array?
If Token.Kind = tkLeftParenthesis Then
Set Token = NextToken
If Token.Kind <> tkRightParenthesis Then Fail Token, Msg036, Msg057
Debug.Assert Not Dcl.DataType Is Nothing
Dcl.DataType.IsArray = True

Set Token = NextToken
End If
End If

If Dcl.IsSub Then
Set Tkn = New Token
Tkn.Kind = tkKeyword
Tkn.Code = kwVoid

Dcl.DataType = NewDataType(Tkn)

ElseIf Dcl.DataType Is Nothing Then
If Dcl.Id.Name.Suffix = vbNullChar Then
Set Dcl.DataType = Entity.DefTypes(NameOf(Dcl.Id.Name))
Else
Set Dcl.DataType = FromChar(Dcl.Id.Name.Suffix)
End If
End If

' Ensure it is not duplicated.
If Entity.Declares.Exists(NameOf(Dcl.Id.Name)) Then Fail Dcl.Id, Msg006 & NameOf(Dcl.Id.Name)

' Must end with a line break
If Not IsBreak(Token) Then MustEatLineBreak

Entity.Declares.AddKeyValue NameOf(Dcl.Id.Name), Dcl
End Sub

Private Function ParseParms(ByVal Entity As Entity, ByVal SignatureKind As SignatureKind, ByVal Parms As KeyedList) As Token
Dim Count As Integer
Dim Index As Integer
Dim Name As String
Dim Token As Token
Dim LastParm As Parameter
Dim CurrParm As Parameter

Debug.Assert Not Parms Is Nothing

Set LastParm = New Parameter
Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = NextToken

If Token.Kind <> tkRightParenthesis Then
Do
Set CurrParm = New Parameter
CurrParm.Index = Index
Index = Index + 1
If Index >= 60 Then Fail Token, Msg042

If IsKw(Token, kwOptional) Then
If LastParm.IsParamArray Then Fail Token, Msg043
If SignatureKind = EventKind Or SignatureKind = TupleKind Then Fail Token, Msg044
CurrParm.IsOptional = True
Set Token = NextToken

ElseIf IsKw(Token, kwParamArray) Then
If LastParm.IsOptional Then Fail Token, Msg043
If SignatureKind = EventKind Or SignatureKind = TupleKind Then Fail Token, Msg045
CurrParm.IsParamArray = True
Set Token = NextToken
End If

If IsKw(Token, kwByVal) Then
If CurrParm.IsParamArray Or SignatureKind = TupleKind Then Fail Token, Msg046
CurrParm.IsByVal = True
Set Token = NextToken

ElseIf IsKw(Token, kwByRef) Then
If CurrParm.IsParamArray Or SignatureKind = TupleKind Then Fail Token, Msg047
' CurrParm.IsByVal = False
Set Token = NextToken
End If

If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, Msg041, Msg003
Set CurrParm.Id = NewId(Token)

Set Token = NextToken

If Token.Kind = tkLeftParenthesis Then
Set Token = NextToken
If Token.Kind <> tkRightParenthesis Then Fail Token, Msg041, ")"
CurrParm.IsArray = True
Set Token = NextToken
End If

If CurrParm.IsParamArray And Not CurrParm.IsArray Then Fail CurrParm.Id, Msg048

If IsKw(Token, kwAs) Then
If CurrParm.Id.Name.Suffix <> vbNullChar Then Fail Token, Msg049
Set Token = NextToken

If SignatureKind = DeclareKind Then
If Not IsDataType(Token) Then Fail Token, Msg041, Msg025
Else
If Not IsProperDataType(Token) Then Fail Token, Msg041, Msg025
End If

Set CurrParm.DataType = NewDataType(Token)
Set Token = NextToken

If IsOp(Token, opDot) Then
Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, Msg050, Msg003

Set CurrParm.DataType.Id.Name = Token

If CurrParm.IsParamArray And ( _
Not CurrParm.DataType.Id.Project Is Nothing Or _
CurrParm.DataType.Id.Name.Code <> kwVariant) Then _
Fail Token, Msg051

Set Token = NextToken
End If

ElseIf CurrParm.Id.Name.Suffix <> vbNullChar Then
Set CurrParm.DataType = FromChar(CurrParm.Id.Name.Suffix)

Else
Set CurrParm.DataType = Entity.DefTypes(NameOf(CurrParm.Id.Name))
End If

If IsOp(Token, opEq) Then
If Not CurrParm.IsOptional Then Fail Token, Msg053
If CurrParm.IsParamArray Then Fail Token, Msg054
Set CurrParm.Init = GetExpression
Set Token = NextToken
End If

If Not CurrParm.IsOptional And (LastParm.IsOptional Or LastParm.IsParamArray) Then
If SignatureKind <> PropertyLetKind And SignatureKind <> PropertySetKind Then _
Fail CurrParm.Id, Msg041, vOptional

GoSub AddParm
Set Token = NextToken
Exit Do
End If

GoSub AddParm
Set LastParm = CurrParm
If Token.Kind <> tkListSeparator Then Exit Do
Set Token = NextToken
Loop
End If

If SignatureKind = PropertyLetKind Or SignatureKind = PropertySetKind Then
If Parms.Count = 0 Then
Fail Token, Msg055

ElseIf LastParm.IsOptional Or LastParm.IsParamArray Then
Fail LastParm.Id, Msg056
End If
End If

If Token.Kind <> tkRightParenthesis Then Fail Token, Msg057
Set ParseParms = NextToken
Exit Function

AddParm:
Name = NameOf(CurrParm.Id.Name)

If Parms.Exists(Name) Then
If SignatureKind <> DeclareKind Then Fail CurrParm.Id, Msg040
Count = 1

Do
Name = NameOf(CurrParm.Id.Name) & "_" & CStr(Count)
If Not Parms.Exists(Name) Then Exit Do
Count = Count + 1
Loop
End If

Parms.AddKeyValue Name, CurrParm
Return
End Function

Private Sub ParseEvent(ByVal Entity As Entity)
Dim Token As Token
Dim Evt As EventConstruct

Set Token = SkipLineBreaks
If Not IsProperId(Token) Then Fail Token, Msg012, Msg003

Set Evt = New EventConstruct
Set Evt.Id = NewId(Token)

Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Entity, EventKind, Evt.Parameters)

If Not IsBreak(Token) Then Fail Token, Msg012, Msg031
If Entity.Events.Exists(NameOf(Evt.Id.Name)) Then Fail Evt.Id, Msg006 & NameOf(Evt.Id.Name)
Entity.Events.AddKeyValue NameOf(Evt.Id.Name), Evt
End Sub

Private Function GetExpression() As Token
Dim Token As Token

' TODO: Complete it.
Set Token = NextToken
If Token.Kind = tkEndOfStream Then Fail Token, "expression", "expression"
Set GetExpression = Token
End Function

Private Sub MustEatLineBreak()
Dim Token As Token

Set Token = NextToken
If IsBreak(Token) Then Exit Sub
If Token.Kind = tkComment Then Exit Sub
Fail Token, Msg005, Msg031
End Sub

Private Function SkipLineBreaks() As Token
Dim Token As Token

Do
Set Token = NextToken
Loop While Token.Kind = tkSoftLineBreak Or Token.Kind = tkHardLineBreak Or Token.Kind = tkComment

Set SkipLineBreaks = Token
End Function

Private Function IsKw(ByVal Token As Token, ByVal Code As Long) As Boolean
Debug.Assert Not Token Is Nothing

If Token.Kind <> tkKeyword Then Exit Function
If Token.Code <> Code Then Exit Function
IsKw = True
End Function

Private Function IsId(ByVal Token As Token, Optional ByVal CanHaveSuffix As Boolean) As Boolean
Debug.Assert Not Token Is Nothing

If Not CanHaveSuffix And Token.Suffix <> vbNullChar Then Fail Token, Msg060
IsId = Token.Kind = tkIdentifier Or Token.Kind = tkEscapedIdentifier
End Function

Private Function IsProperId(ByVal Token As Token, Optional ByVal CanHaveSuffix As Boolean) As Boolean
Const ASCII_US = 95
Const ASCII_ZERO = 46
Const ASCII_NINE = 57

Dim Pos As Integer
Dim IsOK As Boolean
Dim Cp As Integer
Dim Text As String

Debug.Assert Not Token Is Nothing
If Not CanHaveSuffix And Token.Suffix <> vbNullChar Then Fail Token, Msg060

If Token.Kind = tkIdentifier Then
IsProperId = True
Exit Function
End If

If Token.Kind <> tkEscapedIdentifier Then Exit Function
Text = NameOf(Token)

For Pos = 1 To Len(Text)
Cp = AscW(Mid$(Text, Pos, 1))
IsOK = Cp = ASCII_US
If Not IsOK Then IsOK = Cp >= ASCII_ZERO And Cp <= ASCII_NINE
If Not IsOK Then IsOK = IsLetter(Cp)
If Not IsOK Then IsOK = IsSurrogate(Cp)
If Not IsOK Then Exit Function
Next

IsProperId = True
End Function

Private Function IsBreak(ByVal Token As Token) As Boolean
Debug.Assert Not Token Is Nothing

IsBreak = Token.Kind = tkSoftLineBreak Or Token.Kind = tkHardLineBreak Or Token.Kind = tkComment
End Function

Private Function IsOp(ByVal Token As Token, ByVal Code As Long) As Boolean
Debug.Assert Not Token Is Nothing

If Token.Kind <> tkOperator Then Exit Function
IsOp = Token.Code = Code
End Function

Private Function IsProperDataType(ByVal Token As Token) As Boolean
Debug.Assert Not Token Is Nothing
If Token.Suffix <> vbNullChar Then Fail Token, Msg060

Select Case Token.Kind
Case tkIdentifier
IsProperDataType = True

Case tkEscapedIdentifier
IsProperDataType = IsProperId(Token)

Case tkKeyword
Select Case Token.Code
Case kwBoolean, kwByte, kwInteger, kwLong, kwLongLong, kwLongPtr, kwCurrency, cxDecimal, _
kwSingle, kwDouble, kwDate, kwString, cxObject, kwVariant
IsProperDataType = True
End Select
End Select
End Function

Private Function IsDataType(ByVal Token As Token) As Boolean
Debug.Assert Not Token Is Nothing
If Token.Suffix <> vbNullChar Then Fail Token, Msg060

If Token.Kind = tkKeyword And Token.Code = kwAny Then
IsDataType = True
Exit Function
End If

IsDataType = IsProperDataType(Token)
End Function

Private Function IsEndOfContext(ByVal Token As Token) As Boolean
Dim Result As Boolean

Debug.Assert Not Token Is Nothing

Result = IsBreak(Token)
If Not Result Then Result = Token.Kind = tkRightParenthesis
If Not Result Then Result = Token.Kind = tkListSeparator
If Not Result Then Result = Token.Kind = tkPrintSeparator

If Not Result And Token.Kind = tkKeyword Then
Result = Token.Code = kwThen
If Not Result Then Result = Token.Code = kwElse
If Not Result Then Result = Token.Code = kwElse
End If

If Not Result Then Result = Token.Kind = tkIdentifier And Token.Code = cxStep
IsEndOfContext = Result
End Function

Private Sub Fail(ByVal Token As Token, ByVal Message As String, Optional ByVal Expected As String)
Dim Ch As Integer
Dim Msg As String
Dim Got As String
Dim Text As String

Debug.Assert Not Token Is Nothing

Select Case Token.Kind
Case tkEscapedIdentifier
Got = "[" & NameOf(Token) & "]"

Case tkFileHandle
Got = "#" & NameOf(Token)

Case Else
Got = NameOf(Token)
End Select

If Token.Suffix <> vbNullChar Then Got = Got & Token.Suffix
Text = NameOf(Token)

If Len(Text) = 1 Then
Ch = AscW(Text)
If Ch <= 32 Then Got = "Character " & Ch
End If

Msg = "Parser Error" & vbNewLine & _
"File: '" & Source_.Path & "'" & vbNewLine & _
"Line: " & Token.Line & vbNewLine & _
"Column: " & Token.Column & vbNewLine
If Expected <> "" Then Msg = Msg & "Expected: " & Expected & vbNewLine
Msg = Msg & "Got: " & Got & vbNewLine & Message
Err.Raise vbObjectError + 13, , Msg
End Sub

Private Function FromChar(ByVal TypeDeclarationChar As String) As DataType
Dim Token As Token

Set Token = New Token
Token.Kind = tkKeyword

Select Case TypeDeclarationChar
Case "%"
Token.Code = kwInteger

Case "&"
Token.Code = kwLong

Case "^"
Token.Code = kwLongLong

Case "@"
Token.Code = kwCurrency

Case "!"
Token.Code = kwSingle

Case "#"
Token.Code = kwDouble

Case "$"
Token.Code = kwString

Case Else
Debug.Assert False
End Select

Set FromChar = NewDataType(Token)
End Function

Public Function NameOf(ByVal Token As Token) As String
With Scanner_
Select Case Token.Kind
Case tkOperator
NameOf = .Operators(Token.Code)

Case tkKeyword
If Token.Code <= .Keywords.Count Then
NameOf = .Keywords(Token.Code)
Else
NameOf = .Contextuals(Token.Code - .Keywords.Count)
End If

Case Else
If Token.Code <= .Keywords.Count + .Contextuals.Count Then
NameOf = .Contextuals(Token.Code - .Keywords.Count)
Else
NameOf = .Ids(Token.Code - .Keywords.Count - .Contextuals.Count)
End If
End Select
End With
End Function
End Class

Module Program
Option Explicit
Option Compare Binary

Private Const SPAN_STRING = "<span style='color:brown;'>"
Private Const SPAN_KEYWORD = "<span style='color:blue;'>"
Private Const SPAN_COMMENT = "<span style='color: green;'>"

Public Sub Main()
' Dim Source As SourceFile
' Dim Parser As Parser

' Set Source = New SourceFile
' Source.Path = Command$

' Set Parser = New Parser
' Parser.Parse Source
PrettyPrint
End Sub

Public Sub PrettyPrint()
Dim Nbsp As Boolean
Dim HtmlFile As Integer
Dim Index As Integer
Dim Text As String
Dim FilePath As String
Dim Token As Token
Dim Parser As Parser
Dim Source As SourceFile

' Ensuring we close the file in case we have an error.
On Error GoTo CloseIt

' File path for the source code is passed as a command-line argument.
Set Source = New SourceFile
FilePath = Command$
Source.Path = FilePath

Set Parser = New Parser
Set Parser.SourceFile = Source

' Output file will have the same name as the input file, but with an .HTML extension.
Index = InStrRev(FilePath, ".")
If Index <> 0 Then FilePath = Left$(FilePath, Index - 1)

FilePath = FilePath & ".html"
HtmlFile = FreeFile
Open FilePath For Output Access Write As #HtmlFile

Nbsp = True

Do
DoEvents
Set Token = Parser.NextToken

If Nbsp Then
For Index = 1 To Token.Spaces
Print #HtmlFile, "&nbsp;&nbsp;&nbsp;&nbsp;";
Next
Else
Print #HtmlFile, Space$(Token.Spaces);
End If

Select Case Token.Kind
Case tkComment
Print #HtmlFile, SPAN_COMMENT; EncodeHtml(Token.Text); "</span><br>"
Nbsp = True

Case tkIdentifier
Print #HtmlFile, Parser.NameOf(Token);
Nbsp = False

Case tkIntegerNumber, tkFloatNumber, tkSciNumber
Print #HtmlFile, Token.Text;
Nbsp = False

Case tkEscapedIdentifier
Print #HtmlFile, "["; Token.Text; "]";
Nbsp = False

Case tkKeyword
Print #HtmlFile, SPAN_KEYWORD; Parser.NameOf(Token); "</span>";
Nbsp = False

Case tkOctalNumber
Print #HtmlFile, "&amp;O"; Token.Text;

Case tkHexaNumber
Print #HtmlFile, "&amp;H"; UCase$(Token.Text);

Case tkFileHandle
Print #HtmlFile, "#"; Token.Text;

Case tkString
Text = Token.Text
Text = Replace(Token.Text, """", """""")
Text = EncodeHtml(Text)
Print #HtmlFile, SPAN_STRING; """"; Text; """</span>";

Case tkDateTime
Print #HtmlFile, "#"; Token.Text; "#";

Case tkOperator
If IsLetter(AscW(Parser.NameOf(Token))) Then
Print #HtmlFile, SPAN_KEYWORD; Parser.NameOf(Token); "</span>";

ElseIf Left$(Parser.NameOf(Token), 1) = "~" Then
Print #HtmlFile, Mid$(Parser.NameOf(Token), 2);

Else
Print #HtmlFile, EncodeHtml(Parser.NameOf(Token));
End If

Case tkLeftParenthesis
Print #HtmlFile, "(";
Nbsp = False

Case tkRightParenthesis
Print #HtmlFile, ")";
Nbsp = False

Case tkListSeparator
Print #HtmlFile, ",";
Nbsp = False

Case tkSoftLineBreak
Print #HtmlFile, ":";
Nbsp = False

Case tkPrintSeparator
Print #HtmlFile, ";";
Nbsp = False

Case tkLineContinuation
Print #HtmlFile, "&nbsp;_<br>"
Nbsp = True

Case tkHardLineBreak
Print #HtmlFile, "<br />"
Nbsp = True

Case tkDirective
Print #HtmlFile, "#"; Token.Text;
Nbsp = False

Case tkEndOfStream
Exit Do
End Select

If Token.Suffix <> vbNullChar Then Print #HtmlFile, Token.Suffix;
Loop

CloseIt:
Close #HtmlFile
' This is equivalent to a Throw in a Catch.
If Err.Number Then Err.Raise Err.Number
End Sub

Private Function EncodeHtml(ByVal Text As String) As String
Text = Replace(Text, "&", "&amp;")
Text = Replace(Text, "<", "&lt;")
Text = Replace(Text, ">", "&gt;")
EncodeHtml = Text
End Function
End Module