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

Let's build a transpiler! Part 27

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

Last time I said we'll start dealing with the procedure area.
That means dealing with Subs, Functions, and Propertys.

But before that, let me tell you that I made an "extreme makeover" to our code: Now back to parsing Subs, Functions, and Propertys:
The creation of SubConstruct and FunctionConstruct classes were pretty mundane. But properties are a different kind of beast.
See, we cannot have two subs or functions with the same name, but we can have up to three "different" properties with the same name, as long as they differ one from the other by their Get, Let, or Set attribute.
Because of that, I created a PropertySlot class that will hold the three PropertyConstructs.
PropertySlot has an API that resembles the one from a collection - it has Add, Exists, etc.

Then I followed the familiar steps of changing Entity class to have Subs, Functions, and Properties, and adapting the ParseDeclarationArea method.
We know we are done parsing the declaration area when we find not only a Sub, Function, or Property token, but a Static, a Friend, an Iterator, or a Default too because they can only belong to a Sub, a Function, or a Property.

But we have a problem. We may have parsed a Public or a Private token and then stumble upon a Static, Sub, Function, or Property one.
We must be able to pass that Public or Private token to ParseProcedureArea along with the last token so it can deal properly with them.
That's why I created an AccessToken type and made ParseDeclarationArea return it instead of a single token.
We'll stuff it with our current Access value and the last Token read and give it to the caller code. It will then hand it over to ParseProcedureArea.

Then I changed ParseProcedureArea and created ParseSub, ParseFunction, and ParseProperty methods.
Somehow I've found it easier to work on these three methods at the same time.

Subs, Functions, and Propertys have lines of code. They will be represented by a collection of statement objects in a Body property.
To deal with statements, I created a StmtNumbers enum, an IStmt interface, and a bunch of classes implementing IStmt, one for each VB statement.
As we start fleshing them out, we'll need to create a few more complimentary classes.

Finally, I created a ParseBody stub.
Sorry to dump the whole code again...

Next week we'll deal with Dims, Consts, Static variables, line numbers, and labels.

Andrej Biasic
2021-03-03

Public Module ForwardCompatibility
Option Explicit

Public Const vbLongLong = 20
Public Const vbLongPtr = 37

Public Enum LongPtr
Zero
End Enum
End Module

Private Module Globals
Option Explicit

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

Public Function NewOperator(ByVal Token As Token) As Operator
Dim Result As Operator

Set Result = New Operator
Set Result.Value = Token
Set NewOperator = Result
End Function

Public Function NewValidator(ByVal AllowedType As String) As DefaultValidator
Dim Result As DefaultValidator

Set Result = New DefaultValidator
Result.AllowedType = AllowedType
Set NewValidator = Result
End Function

Public Function SizeOf(ByVal VariableType As Long) As Integer
Select Case VariableType
Case kwBoolean, kwInteger
SizeOf = 2

Case kwByte
SizeOf = 1

Case kwLong, kwSingle
SizeOf = 4

Case kwLongLong, kwCurrency, kwDouble, kwDate
SizeOf = 8

Case cxDecimal
SizeOf = 16

Case cxObject ' Pointer
#If Win32 Then
SizeOf = 4
#Else
SizeOf = 8
#End If

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

Case Else
Debug.Assert False
End Select
End Function

Public Function ComparePrecedence(ByVal LeftOp As Operator, ByVal RightOp As Operator) As Integer
Dim LHS As Integer
Dim RHS As Integer

LHS = Precedence(LeftOp)
RHS = Precedence(RightOp)

If LHS = RHS Then Exit Function

If LHS < RHS Then
ComparePrecedence = -1
Else
ComparePrecedence = 1
End If
End Function

Private Function Precedence(ByVal Op As Operator) As Integer
Select Case Op.Value.Code
Case opApply
Precedence = 19

Case opPow
Precedence = 18

Case opAddressOf, opNew, opByVal
Precedence = 17

Case opId, opNeg, opDot, opBang, opWithDot, opWithBang, opTypeOf
Precedence = 16

Case opLSh, opRSh, opURSh
Precedence = 15

Case opMul, opDiv
Precedence = 14

Case opIntDiv
Precedence = 13

Case opMod
Precedence = 12

Case opSum, opSubt
Precedence = 11

Case opConcat
Precedence = 10

Case opGt, opGe, opEq, opLe, opLt, opNe, opIsNot, opIs, opLike, opTo
Precedence = 9

Case opNot
Precedence = 8

Case opAnd, opAndAlso
Precedence = 7

Case opOr, opOrElse
Precedence = 6

Case opXor
Precedence = 5

Case opEqv
Precedence = 4

Case opImp
Precedence = 3

Case opNamed
Precedence = 2

Case opCompSum, opCompSubt, opCompMul, opCompDiv, opCompIntDiv, opCompPow, opCompConcat, opCompLSh, _
opCompRSh, opCompURSh, opCompAnd, opCompEqv, opCompImp, opCompMod, opCompOr, opCompXor
Precedence = 1

Case Else
Debug.Assert False
End Select
End Function
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)"
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"
End Property

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

Public Property Get Msg009() As String
Msg009 = "Rule: (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 = "Rule: [Public] Event identifier [([parms])]"
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] [, ...]"
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 [, ...]"
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 end of statement"
End Property

Public Property Get Msg028() As String
Msg028 = "Rule: [Public | Private] Enum identifier"
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"
End Property

Public Property Get Msg031() As String
Msg031 = "End of statement"
End Property

Public Property Get Msg032() As String
Msg032 = "Rule: identifier [= expression]"
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

Public Property Get Msg058() As String
Msg058 = "Rule: Implements [project_name.]identifier"
End Property

Public Property Get Msg059() As String
Msg059 = "Project name or identifier"
End Property

Public Property Get Msg060() As String
Msg060 = "Type-declaration character not allowed here"
End Property

Public Property Get Msg061() As String
Msg061 = "(Public | Private | Static | Dim) [WithEvents] identifier[type_declaration_character]" & _
"[([[n To] m[, ...]])] [As (data_type [= expression] | New class_name)] [, ...]"
End Property

Public Property Get Msg062() As String
Msg062 = "Invalid use of New"
End Property

Public Property Get Msg063() As String
Msg063 = "Invalid inside Sub, Function, or Property"
End Property

Public Property Get Msg064() As String
Msg064 = "Invalid use of New with array"
End Property

Public Property Get Msg065() As String
Msg065 = "Invalid expression"
End Property

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

Public Property Get Msg067() As String
Msg067 = "Rule: member_name As data_type"
End Property

Public Property Get Msg068() As String
Msg068 = "Rule: End Type"
End Property

Public Property Get Msg069() As String
Msg069 = "Rule: [Public | Private | Friend] [Static] [Default] Sub identifier[([parms])]"
End Property

Public Property Get Msg070() As String
Msg070 = "Rule: [Public | Private | Friend] [Static] [Default] Function identifier[type_declaration_character]" & _
"[()][([parms])] [As data_type[()]]"
End Property

Public Property Get Msg071() As String
Msg071 = "Rule: [Public | Private | Friend] [Static] [Default] Property (Get | Let | Set) " & _
"identifier[type_declaration_character][()][([parms])] [As data_type[()]]"
End Property

Public Property Get Msg072() As String
Msg072 = "Rule: End Sub"
End Property

Public Property Get Msg073() As String
Msg073 = "Rule: End Function"
End Property

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

Public Property Get Msg075() As String
Msg075 = "Duplicate declaration in current scope"
End Property

Public Property Get Msg076() As String
Msg076 = "Get or Let or Set"
End Property

Public Property Get Msg077() As String
Msg077 = "Definitions of property procedures for the same property are inconsistent, " & _
"or property procedure has an optional parameter, a ParamArray, or an invalid Set final parameter"
End Property

Public Property Get Msg078() As String
Msg078 = "Argument required for Property Let or Property Set"
End Property

Public Property Get Msg079() As String
Msg079 = "Rule: (Public | Private | Friend) identifier"
End Property

Public Property Get Msg080() As String
Msg080 = "Duplicate Static statement"
End Property

Public Property Get Msg081() As String
Msg081 = "Duplicate Iterator statement"
End Property

Public Property Get Msg082() As String
Msg082 = "Duplicate Default statement"
End Property

Public Property Get Msg083() As String
Msg083 = "A Function cannot be both Default and Iterator"
End Property

Public Property Get Msg086() As String
Msg086 = "Expected: Get or Let or Set"
End Property
End Module

Public 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

On Error GoTo ErrHandler
Set Source = New SourceFile
Source.Path = Command$

Set Parser = New Parser
Parser.Parse Source
Exit Sub

ErrHandler:
MsgBox Err.Description, vbCritical, "Parser Error"
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

Rem Ensuring we close the file in case we have an error.
On Error GoTo CloseIt

Rem 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

Rem 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
Set Token = Parser.NextToken(ForPrint:=True)

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
Rem 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

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
Rem Increment reference count.
This.Count = This.Count + 1

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

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

Rem Return it.
AddRefEntry = This.Count
End Function

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

Rem Return it.
ReleaseEntry = This.Count

Rem 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

Rem If quantity 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

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

Rem Get the legal object.
Set Res = Obj

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

Rem 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 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(kwInteger) - 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"
Rem 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"
Rem 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"
Rem Nothing to do

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

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

If Index = -1 Then
Rem 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

Rem 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

Rem 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

Public 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
End Module

Public Module Vocabulary
Option Explicit

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

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

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

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

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

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

Rem 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

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

Rem 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

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

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

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

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

Rem 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

Rem 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

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

Rem 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

Rem 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

Rem 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

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

Rem New!
Public Property Get vIterator() As String
vIterator = "Iterator"
End Property

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

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

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

Rem 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

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

Rem 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

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

Rem 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

Rem 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

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

Rem 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

Rem 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

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

Rem 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

Rem 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

Rem 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

Rem 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
Rem Intentionally blank
End Property

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

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

Rem 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 BinaryExpression
Option Explicit
Implements IExpression

Public LHS As IExpression
Public Operator As Operator
Public RHS As IExpression

Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekBinaryExpr
End Property
End Class

Public Class CallConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snCall
End Property
End Class

Public Class CloseConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snClose
End Property
End Class

Public Class ConstConstruct
Option Explicit

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

Public Class DataType
Option Explicit

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

Public Class DebugContruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snDebug
End Property
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
Set Parms_.T = NewValidator(TypeName(New Parameter))
Parms_.CompareMode = vbTextCompare
End Sub

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

Public Class DefaultValidator
Option Explicit
Option Compare Text
Implements IKLValidator

Public AllowedType As String

Private Function IKLValidator_Validate(ByVal Item As Variant) As Boolean
IKLValidator_Validate = TypeName(Item) = AllowedType
Debug.Assert IKLValidator_Validate
End Function
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 DoConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snDo
End Property
End Class

Public Class EndConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snEnd
End Property
End Class

Public Class Entity
Option Explicit

Private Consts_ As KeyedList
Private Enums_ As KeyedList
Private Declares_ As KeyedList
Private Events_ As KeyedList
Private Impls_ As KeyedList
Private Vars_ As KeyedList
Private Types_ As KeyedList
Private Subs_ As KeyedList
Private Funcs_ As KeyedList
Private Props_ As KeyedList

Public OptionBase As Integer
Public OptionCompare As VbCompareMethod
Public OptionExplicit As Boolean
Public IsClass As Boolean
Public Accessibility As Accessibility
Public Id As Identifier

Private Sub Class_Initialize()
Set Consts_ = New KeyedList
Set Consts_.T = NewValidator(TypeName(New ConstConstruct))
Consts_.CompareMode = vbTextCompare

Set Enums_ = New KeyedList
Set Enums_.T = NewValidator(TypeName(New EnumConstruct))
Enums_.CompareMode = vbTextCompare

Set Declares_ = New KeyedList
Set Declares_.T = NewValidator(TypeName(New DeclareConstruct))
Declares_.CompareMode = vbTextCompare

Set Events_ = New KeyedList
Set Events_.T = NewValidator(TypeName(New EventConstruct))
Events_.CompareMode = vbTextCompare

Set Impls_ = New KeyedList
Set Impls_.T = NewValidator(TypeName(New ImplementsConstruct))
Impls_.CompareMode = vbTextCompare

Set Vars_ = New KeyedList
Set Vars_.T = NewValidator(TypeName(New Variable))
Vars_.CompareMode = vbTextCompare

Set Types_ = New KeyedList
Set Types_.T = NewValidator(TypeName(New TypeConstruct))
Types_.CompareMode = vbTextCompare

Set Subs_ = New KeyedList
Set Subs_.T = NewValidator(TypeName(New SubConstruct))
Subs_.CompareMode = vbTextCompare

Set Funcs_ = New KeyedList
Set Funcs_.T = NewValidator(TypeName(New FunctionConstruct))
Funcs_.CompareMode = vbTextCompare

Set Props_ = New KeyedList
Set Props_.T = NewValidator(TypeName(New PropertySlot))
Props_.CompareMode = vbTextCompare
End Sub

Public Static Property Get DefTypes() As DefType
Dim Hidden As New DefType
Set DefTypes = Hidden
End Property

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 Property Get Impls() As KeyedList
Set Impls = Impls_
End Property

Public Property Get Vars() As KeyedList
Set Vars = Vars_
End Property

Public Property Get Types() As KeyedList
Set Types = Types_
End Property

Public Property Get Subs() As KeyedList
Set Subs = Subs_
End Property

Public Property Get Functions() As KeyedList
Set Functions = Funcs_
End Property

Public Property Get Properties() As KeyedList
Set Properties = Props_
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
Set Enumerands_.T = NewValidator(TypeName(New EnumerandConstruct))
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 IExpression
End Class

Public Class EraseConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snErase
End Property
End Class

Public Class EventConstruct
Option Explicit

Private Parms_ As KeyedList

Public Id As Identifier

Private Sub Class_Initialize()
Set Parms_ = New KeyedList
Set Parms_.T = NewValidator(TypeName(New Parameter))
Parms_.CompareMode = vbTextCompare
End Sub

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

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

Public Class ExitConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snExit
End Property
End Class

Public Class Expressionist
Option Explicit

Private LastToken_ As Token

Public CanHaveTo As Boolean

Public Property Get LastToken() As Token
Set LastToken = LastToken_
End Property

Private Function Peek(ByVal Stack As KeyedList) As Variant
Set Peek = Stack(Stack.Count)
End Function

Private Function Pop(ByVal Stack As KeyedList) As Variant
Dim Index As Long

Index = Stack.Count
Set Pop = Stack(Index)
Stack.Remove Index
End Function

Rem Adapted from https://stackoverflow.com/questions/16380234/handling-extra-operators-in-shunting-yard/16392115#16392115
Public Function GetExpression(ByVal Parser As Parser) As IExpression
Dim HadTo As Boolean
Dim WantOperand As Boolean
Dim Cp As Integer
Dim Token As Token
Dim Sym As Symbol
Dim Lit As Literal
Dim Op As Operator
Dim Op2 As Operator
Dim OpStack As KeyedList
Dim OutStack As KeyedList
Dim Handle As FileHandle

Set OpStack = New KeyedList
Set OpStack.T = NewValidator(TypeName(New Operator))

Set OutStack = New KeyedList
Set OutStack.T = New ExprValidator
WantOperand = True

Do
Set Token = Parser.NextToken

If WantOperand Then
WantOperand = False

Select Case Token.Kind
Case tkOperator
WantOperand = True

Select Case Token.Code
Case opSum
Token.Code = opId

Case opSubt
Token.Code = opNeg

Rem Unary operators
Case opAddressOf, opNew, opNot, opTypeOf, opWithBang, opWithDot
Rem OK

Case Else
Exit Do
End Select

Set Op = NewOperator(Token)
OpStack.Add Op

Case tkLeftParenthesis
Rem Pseudo-operator
Set Op = NewOperator(Token)
OpStack.Add Op
WantOperand = True

Case tkIdentifier, tkEscapedIdentifier
Set Sym = New Symbol
Set Sym.Value = Token
OutStack.Add Sym

Case tkIntegerNumber, tkFloatNumber, tkSciNumber, tkBinaryNumber, _
tkOctalNumber, tkHexaNumber, tkString, tkDateTime
Set Lit = New Literal
Set Lit.Value = Token
OutStack.Add Lit

Case tkFileHandle
Set Handle = New FileHandle
Set Handle.Value = Token
OutStack.Add Handle

Case tkKeyword
Select Case Token.Code
Case kwTrue, kwFalse, kwNothing, kwEmpty, kwNull, kwMe
Set Lit = New Literal
Set Lit.Value = Token
OutStack.Add Lit

Case Else
Exit Do
End Select

Case Else
Exit Do
End Select
Else
If Parser.IsBreak(Token) Then
While OpStack.Count > 0
Move OpStack, OutStack
Wend

Exit Do
End If

Select Case Token.Kind
Case tkOperator
Rem Unary and compound operators
Select Case Token.Code
Case opAddressOf, opNew, opNot, opTypeOf, opCompAnd, opCompEqv, opCompImp, _
opCompMod, opCompOr, opCompXor, opCompSum, opCompSubt, opCompMul, opCompDiv, _
opCompIntDiv, opCompPow, opCompLSh, opCompRSh, opCompURSh, opCompConcat
Parser.Fail Token, Msg065
End Select

Set Op2 = NewOperator(Token)

Do While OpStack.Count > 0
Set Op = Peek(OpStack)
If Op.Value.Kind = tkLeftParenthesis Then Exit Do

Cp = ComparePrecedence(Op, Op2)
If Cp = -1 Then Exit Do
Move OpStack, OutStack, Op
Loop

OpStack.Add Op2
WantOperand = True

Case tkLeftParenthesis
Rem Apply operator
Set Token = New Token
Token.Kind = tkOperator
Token.Code = opApply
Set Op = NewOperator(Token)
OpStack.Add Op

Case tkRightParenthesis
Do While OpStack.Count > 0
Set Op = Peek(OpStack)
If Op.Value.Kind = tkLeftParenthesis Then Exit Do
If Op.Value.IsOperator(opApply) Then Exit Do

Move OpStack, OutStack, Op
Loop

If OpStack.Count = 0 Then Exit Do
Pop OpStack

Case tkKeyword
Select Case Token.Code
Case kwTo
If Not CanHaveTo Or HadTo Then Err.Raise vbObjectError + 13
HadTo = True

Token.Kind = tkOperator
Token.Code = Parser.Scanner.Operators.IndexOf(vTo)
OpStack.Add NewOperator(Token)
WantOperand = True

Case Else
Debug.Assert False
End Select

Case Else
Exit Do
End Select
End If
Loop

Set LastToken_ = Token

Do While OutStack.Count > 1
Set Op = Peek(OpStack)
If Op.Value.Kind = tkLeftParenthesis Then Exit Do

Move OpStack, OutStack, Op
Loop

If OutStack.Count = 1 Then Set GetExpression = Pop(OutStack)
End Function

Private Sub Move(ByVal OpStack As KeyedList, ByVal OutStack As KeyedList, Optional ByVal Op As Operator)
Dim IExpr As IExpression
Dim Uni As UnaryExpression
Dim Bin As BinaryExpression

If Op Is Nothing Then Set Op = Peek(OpStack)

If Op.IsUnary Then
Set Uni = New UnaryExpression
Set Uni.Operator = Op
Set Uni.Value = Pop(OutStack)
Set IExpr = Uni
Else
Set Bin = New BinaryExpression
Set Bin.Operator = Op
Set Bin.RHS = Pop(OutStack)
Set Bin.LHS = Pop(OutStack)
Set IExpr = Bin
End If

OutStack.Add IExpr
Pop OpStack
End Sub
End Class

Public Class ExprValidator
Option Explicit
Implements IKLValidator

Private Function IKLValidator_Validate(ByVal Item As Variant) As Boolean
IKLValidator_Validate = TypeOf Item Is IExpression
End Function
End Class

Public Class FileHandle
Option Explicit
Implements IExpression

Public Value As Token

Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekFileHandle
End Property
End Class

Public Class ForConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snFor
End Property
End Class

Public Class ForEachConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snForEach
End Property
End Class

Public Class FunctionConstruct
Option Explicit

Private Parms_ As KeyedList
Private Body_ As KeyedList

Public Access As Accessibility
Public IsStatic As Boolean
Public IsDefault As Boolean
Public IsIterator As Boolean
Public Id As Identifier
Public DataType As DataType

Private Sub Class_Initialize()
Set Parms_ = New KeyedList
Set Parms_.T = NewValidator(TypeName(New Parameter))
Parms_.CompareMode = vbTextCompare

Set Body_ = New KeyedList
Set Body_.T = New StmtValidator
End Sub

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

Public Static Property Get Body() As KeyedList
Set Body = Body_
End Property
End Class

Public Class GetConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snGet
End Property
End Class

Public Class GoSubConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snGoSub
End Property
End Class

Public Class GoToConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snGoTo
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 IExpression
Option Explicit

Public Enum ExpressionKind
ekLiteral
ekSymbol
ekFileHandle
ekTuple
ekUnaryExpr
ekBinaryExpr
End Enum

Private Sub Class_Initialize()
Err.Raise 5
End Sub

Public Property Get Kind() As ExpressionKind
End Property
End Class

Public Class IfConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snIf
End Property
End Class

Public Class IKLValidator
Option Explicit

Private Sub Class_Initialize()
Err.Raise 5
End Sub

Public Function Validate(ByVal Item As Variant) As Boolean
End Function
End Class

Public Class ImplementsConstruct
Option Explicit

Public Static Property Get Id() As Identifier
Dim Hidden As New Identifier
Set Id = Hidden
End Property
End Class

Public Class InputConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snInput
End Property
End Class

Public Class IStmt
Option Explicit

Public Enum StmtNumbers
snCall = 1
snClose
snConst
snContinue
snDebug
snDim
snDo
snEnd
snErase
snExit
snFor
snForEach
snGet
snGoSub
snGoTo
snIf
snInput
snLabel
snLet
snLineNumber
snLock
snLSet
snName
snOnError
snOnComputed
snOpen
snPrint
snPut
snRaiseEvent
snReDim
snReset
snResume
snReturn
snRSet
snSeek
snSelect
snSet
snStop
snUnlock
snWhile
snWidth
snWith
snWrite
End Enum

Private Sub Class_Initialize()
Err.Raise 5
End Sub

Public Property Get Kind() As StmtNumbers
End Property
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 Validator_ As IKLValidator
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
If Not Validator_ Is Nothing Then: If Not Validator_.Validate(Item) Then Err.Raise 13

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 Iterator 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() As Variant)
Dim Value As Variant

For Each Value In Values
Add Value
Next
End Sub

Public Sub AddKVPairs(ParamArray KeyValuePairs() As Variant)
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

Public Property Set T(ByVal Value As IKLValidator)
Set Validator_ = Value
End Property
End Class

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

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

Public Class LabelConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLabel
End Property
End Class

Public Class LetConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLet
End Property
End Class

Public Class LineNumber
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLineNumber
End Property
End Class

Public Class Literal
Option Explicit
Implements IExpression

Public Value As Token

Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekLiteral
End Property
End Class

Public Class LockConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLock
End Property
End Class

Public Class LSetConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLSet
End Property
End Class

Public Class NameConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snName
End Property
End Class

Public Class OnComputedConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snOnComputed
End Property
End Class

Public Class OnErrorConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snOnError
End Property
End Class

Public Class OpenConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snOpen
End Property
End Class

Public Class Operator
Option Explicit

Public Value As Token

Public Property Get IsUnary() As Boolean
Select Case Value.Code
Case opAddressOf, opNew, opNot, opTypeOf, opId, opNeg, opWithDot, opWithBang, opByVal
IsUnary = True
End Select
End Property

Public Property Get IsBinary() As Boolean
IsBinary = Not IsUnary
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 IExpression
End Class

Public Class Parser
Option Explicit
Option Compare Binary

Public Enum Accessibility
acLocal
acPublic
acPrivate
acFriend
End Enum

Public Enum SignatureKind
skSub = 1
skFunction
skPropertyGet
skPropertyLet
skPropertySet
skDeclare
skEvent
skTuple
End Enum

Private Enum NarrowContext
ncNone
ncOption
ncOptionCompare
ncOn
ncDeclare
ncDeclareLib
ncDeclareAlias
ncForNext
ncForTo
ncOpen01
ncOpen02
ncOpen03
ncOpen04
ncOpen05
ncOpen06
ncOpen07
ncOpen08
ncOpen09
ncOpen10
ncOpen11
End Enum

Private Type AccessToken
Access As Accessibility
Token As Token
End Type

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 AccessToken_ As AccessToken
Private State_ As NarrowContext

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

Rem 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_ = ncNone
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(Optional ByVal ForPrint As Boolean) As Token
Dim Done As Boolean
Dim Revoke As Boolean
Dim Upgrade As Boolean
Dim Spaces As Long
Dim Name As String
Dim Token As Token
Dim LastToken As Token

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_ = ncNone
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
Name = NameOf(Token)

If Scanner_.Ids.Exists(Name) Then
Scanner_.Ids.Add Name, Name
Token.Code = Scanner_.Ids.Count
End If

Token.Kind = tkIdentifier

Else
Select Case Token.Code
Case kwAs
WasAs_ = True

Select Case State_
Case ncOpen03, ncOpen05, ncOpen06, ncOpen08, ncOpen09
State_ = ncOpen10
End Select

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

Case kwDeclare
If State_ = ncNone Then State_ = ncDeclare

Case kwFor
If State_ = ncNone Then
State_ = ncForNext

ElseIf State_ = ncOpen01 Then
State_ = ncOpen02
End If

Case kwInput
If State_ = ncOpen02 Then State_ = ncOpen03

Case cxLock
Select Case State_
Case ncOpen05, ncOpen06
State_ = ncOpen07
End Select

Case kwOpen
If State_ = ncNone Then State_ = ncOpen01

Case kwOption
If State_ = ncNone Then State_ = ncOption

Case kwOn
If State_ = ncNone Then State_ = ncOn

Case cxShared
Select Case State_
Case ncOpen03, ncOpen04, ncOpen06
State_ = ncOpen09
End Select

Case kwTo
If State_ = ncForNext Then State_ = ncForTo

Case kwWrite
Select Case State_
Case ncOpen04, ncOpen05
State_ = ncOpen06

Case ncOpen07, ncOpen08
State_ = ncOpen09
End Select
End Select
End If

Case tkIdentifier
Downgrade_ = False
WasAs_ = False

Select Case State_
Case ncNone
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
End If

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 ncOption
Upgrade = Token.Code = cxBase
If Not Upgrade Then Upgrade = Token.Code = cxExplicit

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

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

Case ncDeclare
Upgrade = Token.Code = kwPtrSafe

If Upgrade Then
State_ = ncDeclareLib
Else
Upgrade = Token.Code = cxLib
If Upgrade Then State_ = ncDeclareAlias
End If

Case ncDeclareLib
Upgrade = Token.Code = cxLib
If Upgrade Then State_ = ncDeclareAlias

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

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

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

Case ncOpen02
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_ = ncOpen03

Case ncOpen03
Upgrade = Token.Code = cxAccess
If Upgrade Then State_ = ncOpen04

Case ncOpen05, ncOpen06
Upgrade = Token.Code = cxShared
If Upgrade Then State_ = ncOpen09

Case ncOpen04
Upgrade = Token.Code = cxRead
If Upgrade Then State_ = ncOpen05

Case ncOpen07
Upgrade = Token.Code = cxRead
If Upgrade Then State_ = ncOpen08

Case ncOpen11
Upgrade = Token.Code = cxLen
Revoke = True
End Select

Case tkFileHandle
If State_ = ncOpen10 Then State_ = ncOpen11

Case tkLineContinuation
If Not ForPrint Then
Set Token = NextToken()

While IsBreak(Token)
Set Token = NextToken()
Wend
End If

Case tkWhiteSpace
Done = False
Spaces = Spaces + 1

Case tkSoftLineBreak, tkHardLineBreak
WasAs_ = False
End Select

If Upgrade Then
If Token.Suffix <> vbNullChar Then Fail Token, Msg060

Token.Kind = tkKeyword
Name = NameOf(Token)
Token.Code = Scanner_.Contextuals.IndexOf(Name) + Scanner_.Keywords.Count
If Revoke Then State_ = ncNone
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

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

Set SourceFile = Source

Do
Set Entity = New Entity

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

If Token.IsKeyword(kwPublic) Then
Entity.Accessibility = acPublic
Set Token = NextToken

ElseIf Token.IsKeyword(kwPrivate) Then
Entity.Accessibility = acPrivate
Set Token = NextToken
End If

If Token.IsKeyword(kwClass) Then
Entity.IsClass = True

ElseIf Token.IsKeyword(kwModule) Then
Rem Nothing to do.

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

Else
Fail Token, Msg007, Msg002
End If

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

Set Entity.Id = NewId(Token)
MustEatLineBreak

AccessToken = ParseDeclarationArea(Entity)
Set Token = AccessToken.Token

If Not Token.IsKeyword(kwEnd) Then
Set Token = ParseProcedureArea(Entity, AccessToken)
If Not Token.IsKeyword(kwEnd) Then Fail Token, Msg004, vEnd
End If

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

If Source_.Entities.Exists(NameOf(Entity.Id.Name)) Then Fail Entity.Id.Name, 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 AccessToken
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 <> acLocal 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 <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbBoolean, Entity

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

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

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

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

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

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

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

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

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

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

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

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

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

Case kwPublic, kwGlobal
If Access <> acLocal Then Fail Token, Msg008, Msg003
Access = acPublic

Case kwPrivate
If Access <> acLocal Then Fail Token, Msg008, Msg003
Access = acPrivate

Case kwConst
If Access = acLocal Then Access = acPrivate
ParseConsts Access, Entity
Access = acLocal

Case kwEnum
ParseEnum Access, Entity
Access = acLocal

Case kwDeclare
ParseDeclare Access, Entity
Access = acLocal

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

Case kwImplements
If Not Entity.IsClass Then Fail Token, Msg016
If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseImplements Entity

Case kwWithEvents
If Access = acLocal Then Access = acPublic
ParseDim Access, Entity, Token:=Token
Access = acLocal

Case kwDim
If Access = acLocal Then Access = acPublic
ParseDim Access, Entity
Access = acLocal

Case kwType
If Access = acLocal Then Access = acPublic
ParseType Access, Entity
Access = acLocal

Case kwFriend
If Access <> acLocal Then Fail Token, Msg008, Msg003
If Not Entity.IsClass Then Fail Token, Msg016
Access = acFriend
Exit Do

Case kwStatic, kwIterator, kwDefault, kwSub, kwFunction, cxProperty, kwEnd
Exit Do

Case Else
Fail Token, Msg018
End Select

ElseIf Token.Kind = tkIdentifier And Token.Code = cxProperty Then
Token.Kind = tkKeyword
Exit Do

ElseIf IsProperId(Token, CanHaveSuffix:=True) Then
ParseDim Access, Entity, Token:=Token
Access = acLocal

Else
Fail Token, Msg018
End If
Loop

With ParseDeclarationArea
.Access = Access
Set .Token = Token
End With
End Function

Private Function ParseProcedureArea(ByVal Entity As Entity, ByRef AccessToken As AccessToken) As Token
Dim IsDefault As Boolean
Dim HadDefault As Boolean
Dim IsIterator As Boolean
Dim HadIterator As Boolean
Dim IsStatic As Boolean
Dim Access As Accessibility
Dim Token As Token

Dim Proc As SubConstruct
Dim Func As FunctionConstruct
Dim Prop As PropertyConstruct

Access = AccessToken.Access
Set Token = AccessToken.Token

Do While Token.Kind = tkKeyword
Select Case Token.Code
Case kwPublic
If Access <> acLocal Then Fail Token, Msg079, Msg003
Access = acPublic

Case kwPrivate
If Access <> acLocal Then Fail Token, Msg079, Msg003
Access = acPrivate

Case kwFriend
If Access <> acLocal Then Fail Token, Msg079, Msg003
Access = acFriend

Case kwDefault
If IsDefault Or HadDefault Then Fail Token, Msg082
HadDefault = True
IsDefault = True

Case kwIterator
If IsIterator Or HadIterator Then Fail Token, Msg081
HadIterator = True
IsIterator = True

Case kwStatic
If IsStatic Then Fail Token, Msg080
IsStatic = True

Case kwSub
Set Proc = ParseSub(Access, Entity)
Proc.IsDefault = IsDefault
Proc.IsStatic = IsStatic
GoSub Cleanup

Case kwFunction
Set Func = ParseFunction(Access, Entity)
Func.IsDefault = IsDefault
Func.IsStatic = IsStatic
Func.IsIterator = IsIterator
If Func.IsDefault And Func.IsIterator Then Fail Token, Msg083
GoSub Cleanup

Case cxProperty
Set Prop = ParseProperty(Access, Entity)
Prop.IsDefault = IsDefault
Prop.IsStatic = IsStatic
GoSub Cleanup

Case Else
Exit Do
End Select

Set Token = SkipLineBreaks
If Token.Kind = tkIdentifier And Token.Code = cxProperty Then Token.Kind = tkKeyword
Loop

Set ParseProcedureArea = Token
Exit Function

Cleanup:
IsStatic = False
IsDefault = False
IsIterator = False
Access = acLocal
Return
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 Token.IsOperator(opSubt) Then
Set Token = NextToken
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
Dim Xp As New Expressionist

Debug.Assert Not Entity Is Nothing

Do
Rem 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

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

Rem Get Const's data type name
Set Token = NextToken
If Not IsConstDataType(Token) Then Fail Token, Msg023, Msg025

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

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

Set Cnt.DataType.FixedLength = Xp.GetExpression(Me)
Set Token = Xp.LastToken
End If

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

Rem Discard "="
If Not Token.IsOperator(opEq) Then Fail Token, Msg023, "="

Rem Get Const's value
Set Cnt.Value = Xp.GetExpression(Me)

Rem Ensure it's not a duplicated Const
CheckDupl Entity, Cnt.Id.Name

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

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

Rem Move on
Set Token = Xp.LastToken
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 Lit As Literal
Dim Enm As EnumConstruct
Dim Emd As EnumerandConstruct
Dim Count As Long
Dim Xp As New Expressionist

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 = acLocal Then Access = acPublic
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 Token.IsKeyword(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 Token.IsOperator(opEq) Then
Set Emd.Value = Xp.GetExpression(Me)
Set Token = Xp.LastToken
Else
Rem TODO Deal when the previous enumerand has an assigned value
Set Lit = New Literal
Set Lit.Value = New Token
Lit.Value.Kind = tkIntegerNumber
Lit.Value.Text = CStr(Count)
Lit.Value.Suffix = "&"
Set Emd.Value = Lit
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 Token.IsKeyword(kwEnd) Then Fail Token, Msg034, vEnd

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

If Enm.Enumerands.Count = 0 Then Fail Enm, Msg035
CheckDupl Entity, 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 = acLocal Then Access = acPublic
Dcl.Access = Access

Rem Is it PtrSafe?
Set Token = NextToken

If Token.IsKeyword(kwPtrSafe) Then
Rem Just ignore it
Set Token = NextToken
End If

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

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

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

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

Set Dcl.Id = NewId(Token)

Rem Maybe there is a CDecl?
Set Token = NextToken

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

Rem Discard Lib
If Not Token.IsKeyword(cxLib) Then Fail Token, Msg036, vLib

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

Rem Maybe there is an Alias?
Set Token = NextToken

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

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

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

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

Rem 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 Token.IsOperator(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
If Not IsBuiltinDataType(Token) Then Fail Token, Msg036, Msg025
Set Dcl.DataType = NewDataType(Token)
Set Token = NextToken

Case Else
Fail Token, Msg036, Msg025
End Select

Rem 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

Set 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

Rem Ensure it is not duplicated.
CheckDupl Entity, Dcl.Id.Name

Rem 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
Dim Xp As New Expressionist

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 Token.IsKeyword(kwOptional) Then
If LastParm.IsParamArray Then Fail Token, Msg043
If SignatureKind = skEvent Or SignatureKind = skTuple Then Fail Token, Msg044
CurrParm.IsOptional = True
Set Token = NextToken

ElseIf Token.IsKeyword(kwParamArray) Then
If LastParm.IsOptional Then Fail Token, Msg043
If SignatureKind = skEvent Or SignatureKind = skTuple Then Fail Token, Msg045
CurrParm.IsParamArray = True
Set Token = NextToken
End If

If Not CurrParm.IsParamArray Then
If Token.IsKeyword(kwByVal) Then
If SignatureKind = skTuple Then Fail Token, Msg046
CurrParm.IsByVal = True
Set Token = NextToken

ElseIf Token.IsKeyword(kwByRef) Then
If SignatureKind = skTuple Then Fail Token, Msg047
CurrParm.IsByVal = False ' Technically this is not needed
Set Token = NextToken
End If
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 Token.IsKeyword(kwAs) Then
If CurrParm.Id.Name.Suffix <> vbNullChar Then Fail Token, Msg049
Set Token = NextToken

If SignatureKind = skDeclare 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 Token.IsOperator(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 Token.IsOperator(opEq) Then
If Not CurrParm.IsOptional Then Fail Token, Msg053
If CurrParm.IsParamArray Then Fail Token, Msg054
Set CurrParm.Init = Xp.GetExpression(Me)
Set Token = Xp.LastToken
End If

If Not CurrParm.IsOptional And (LastParm.IsOptional Or LastParm.IsParamArray) Then
If SignatureKind <> skPropertyLet And SignatureKind <> skPropertySet 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 = skPropertyLet Or SignatureKind = skPropertySet 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 <> skDeclare 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, skEvent, Evt.Parameters)

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

Private Sub ParseImplements(ByVal Entity As Entity)
Dim Name As String
Dim Token As Token
Dim Impls As ImplementsConstruct

Set Token = SkipLineBreaks
If Token.Kind <> tkIdentifier Then Fail Token, Msg058, Msg059
If Token.Suffix <> vbNullChar Then Fail Token, Msg060

Set Impls = New ImplementsConstruct
Set Impls.Id.Name = Token

Set Token = NextToken

If Token.IsOperator(opDot) Then
Set Token = NextToken
If Token.Kind <> tkIdentifier Then Fail Token, Msg058, Msg003
If Token.Suffix <> vbNullChar Then Fail Token, Msg060

Set Impls.Id.Name = Token
Set Token = NextToken
End If

If Not IsBreak(Token) Then Fail Token, Msg058, Msg031
Name = NameOf(Token)
If Entity.Impls.Exists(Name) Then Fail Token, Msg006 & Name
Entity.Impls.Add Impls, Name
End Sub

Private Function ParseSub(ByVal Access As Accessibility, ByVal Entity As Entity) As SubConstruct
Dim Token As Token
Dim Proc As SubConstruct
Dim Name As String

If Access = acLocal Then Access = acPublic
Set Proc = New SubConstruct
Proc.Access = Access

Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, Msg069, Msg003

Set Proc.Id = NewId(Token)
Set Token = NextToken

If Token.Kind = tkLeftParenthesis Then
Set Token = ParseParms(Entity, skSub, Proc.Parameters)

ElseIf Not IsBreak(Token) Then
Fail Token, Msg069, Msg031
End If

Set Token = ParseBody(Proc.Body)
If Not Token.IsKeyword(kwEnd) Then Fail Token, Msg072, vEnd

Set Token = NextToken
If Not Token.IsKeyword(kwSub) Then Fail Token, Msg072, vSub

MustEatLineBreak

Name = NameOf(Proc.Id.Name)
CheckDupl Entity, Proc.Id.Name
Entity.Subs.Add Proc, Name

Set ParseSub = Proc
End Function

Private Function ParseFunction(ByVal Access As Accessibility, ByVal Entity As Entity) As FunctionConstruct
Dim Token As Token
Dim Func As FunctionConstruct
Dim Name As String
Dim Parm As Parameter

If Access = acLocal Then Access = acPublic
Set Func = New FunctionConstruct
Func.Access = Access

Set Token = NextToken
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, Msg070, Msg003

Set Func.Id = NewId(Token)
Name = NameOf(Func.Id.Name)

Set Token = NextToken

If Token.Kind = tkLeftParenthesis Then
Set Token = ParseParms(Entity, skFunction, Func.Parameters)

ElseIf Not IsBreak(Token) Then
Fail Token, Msg070, Msg031
End If

For Each Parm In Func.Parameters
If StrComp(Name, NameOf(Parm.Id.Name), vbTextCompare) = 0 Then Fail Parm.Id.Name, Msg075
Next

If Token.IsKeyword(kwAs) Then
Set Token = NextToken
If Not IsProperDataType(Token) Then Fail Token, Msg050, Msg059
Set Func.DataType = NewDataType(Token)

Set Token = NextToken

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

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

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

Else
Set Func.DataType = Entity.DefTypes(Name)
End If

If Token.Kind = tkLeftParenthesis Then
Set Token = NextToken
If Token.Kind <> tkRightParenthesis Then Fail Token, Msg057
Func.DataType.IsArray = True
End If

If Not IsBreak(Token) Then MustEatLineBreak
Set Token = ParseBody(Func.Body)
If Not Token.IsKeyword(kwEnd) Then Fail Token, Msg073, vEnd

Set Token = NextToken
If Not Token.IsKeyword(kwFunction) Then Fail Token, Msg073, vFunction

MustEatLineBreak

CheckDupl Entity, Func.Id.Name
Entity.Functions.Add Func, Name

Set ParseFunction = Func
End Function

Private Function ParseProperty(ByVal Access As Accessibility, ByVal Entity As Entity) As PropertyConstruct
Dim IsNew As Boolean
Dim Idx As Integer
Dim Name As String
Dim Token As Token
Dim PropToken As Token
Dim LeftParms As KeyedList
Dim RightParms As KeyedList
Dim Parm As Parameter
Dim Kind As VbCallType
Dim Slot As PropertySlot
Dim Prop As PropertyConstruct

If Access = acLocal Then Access = acPublic
Set Prop = New PropertyConstruct
Prop.Access = Access

Set Token = NextToken

If Token.Kind <> tkKeyword Then Fail Token, Msg086

Select Case Token.Code
Case kwGet
Kind = VbGet

Case kwLet
Kind = VbLet

Case kwSet
Kind = VbSet

Case Else
Fail Token, Msg071, Msg076
End Select

Set Token = NextToken
If Not IsProperId(Token, CanHaveSuffix:=Kind = VbGet) Then Fail Token, Msg071, Msg003

Set PropToken = Token
Name = NameOf(Token)

CheckDupl Entity, Token, JumpProp:=True

If Entity.Properties.Exists(Name) Then
Set Slot = Entity.Properties(Name)
Else
IsNew = True
Set Slot = New PropertySlot
Set Slot.Id = NewId(Token)
End If

Set Token = NextToken

If Token.Kind = tkLeftParenthesis Then
Set Token = ParseParms( _
Entity, _
Switch(Kind = VbGet, skPropertyGet, Kind = VbLet, skPropertyLet, True, skPropertySet), _
Prop.Parameters _
)

ElseIf Not IsBreak(Token) Then
Fail Token, Msg071, Msg031
End If

If Kind = VbGet Then
For Each Parm In Prop.Parameters
If StrComp(Name, NameOf(Parm.Id.Name), vbTextCompare) = 0 Then Fail Parm.Id.Name, Msg075
Next

If Token.IsKeyword(kwAs) Then
Set Token = NextToken
If Not IsProperDataType(Token) Then Fail Token, Msg050, Msg059
Set Slot.DataType = NewDataType(Token)

Set Token = NextToken

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

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

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

Else
Set Slot.DataType = Entity.DefTypes(Name)
End If

If Token.Kind = tkLeftParenthesis Then
Set Token = NextToken
If Token.Kind <> tkRightParenthesis Then Fail Token, Msg057
Slot.DataType.IsArray = True
End If

ElseIf Prop.Parameters.Count = 0 Then
Fail Slot.Id.Name, Msg078
End If

If Kind = VbSet Then
If IsBuiltinDataType(Prop.Parameters(Prop.Parameters.Count).Id.Name) Then Fail Slot.Id.Name, Msg077
End If

Set Token = ParseBody(Prop.Body)
If Not Token.IsKeyword(kwEnd) Then Fail Token, Msg074, vEnd

Set Token = NextToken
If Token.Kind <> tkIdentifier Or Token.Code <> cxProperty Then Fail Token, Msg074, vProperty

MustEatLineBreak

If IsNew Then
Slot.Add Kind, Prop
Entity.Properties.Add Slot, Name
Else
If Slot.Exists(Kind) Then Fail PropToken, Msg006 & Name
Slot.Add Kind, Prop
End If

If Kind <> VbGet Then
Set Parm = Prop.Parameters(Prop.Parameters.Count)
If Parm.IsOptional Then Fail Slot.Id.Name, Msg077
If Parm.IsParamArray Then Fail Slot.Id.Name, Msg077
End If

If Slot.Exists(VbGet) And Slot.Exists(VbLet) Then
Set LeftParms = Slot(VbGet).Parameters
Set RightParms = Slot(VbLet).Parameters
If LeftParms.Count + 1 <> RightParms.Count Then Fail Slot.Id.Name, Msg077

For Idx = 1 To LeftParms.Count
If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail LeftParms(Idx).Id.Name, Msg075
Next

If Kind = VbGet Then
If Slot.DataType.IsArray <> RightParms(RightParms.Count).DataType.IsArray Then Fail Slot.Id.Name, Msg077
If Slot.DataType.Id.Name.Code <> RightParms(RightParms.Count).DataType.Id.Name.Code Then _
Fail Slot.Id.Name, Msg077
End If
End If

If Slot.Exists(VbGet) And Slot.Exists(VbSet) Then
Set LeftParms = Slot(VbGet).Parameters
Set RightParms = Slot(VbSet).Parameters
If LeftParms.Count + 1 <> RightParms.Count Then Fail Slot.Id.Name, Msg077

For Idx = 1 To LeftParms.Count
If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail Slot.Id.Name, Msg077
Next
End If

If Slot.Exists(VbLet) And Slot.Exists(VbSet) Then
Set LeftParms = Slot(VbLet).Parameters
Set RightParms = Slot(VbSet).Parameters
If LeftParms.Count <> RightParms.Count Then Fail Slot.Id.Name, Msg077

For Idx = 1 To LeftParms.Count
If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail Slot.Id.Name, Msg077
Next
End If

Set ParseProperty = Prop
End Function

Private Function AreEqual(ByVal LeftParm As Parameter, ByVal RightParm As Parameter) As Boolean
If LeftParm.IsArray <> RightParm.IsArray Then Exit Function
If LeftParm.IsByVal <> RightParm.IsByVal Then Exit Function
If LeftParm.IsOptional <> RightParm.IsOptional Then Exit Function
If LeftParm.IsParamArray <> RightParm.IsParamArray Then Exit Function
If LeftParm.DataType.Id.Name.Code <> RightParm.DataType.Id.Name.Code Then Exit Function
AreEqual = True
End Function

Private Function ParseBody(ByVal Body As KeyedList) As Token
Rem TODO: Complete
Set ParseBody = SkipLineBreaks
End Function

Private Function SynthLower(ByVal Entity As Entity) As IExpression
Dim Lit As Literal
Dim Tkn As Token

Set Tkn = New Token
Tkn.Kind = tkIntegerNumber
Tkn.Text = CStr(Entity.OptionBase)

Set Lit = New Literal
Set Lit.Value = Tkn

Set SynthLower = Lit
End Function

Private Sub ParseDim( _
ByVal Access As Accessibility, _
ByVal Entity As Entity, _
Optional ByVal InsideProc As Boolean, _
Optional ByVal Token As Token _
)
Dim Name As String
Dim WasArray As Boolean
Dim Tkn As Token
Dim Lit As Literal
Dim Var As Variable
Dim Expr As IExpression
Dim Subs As SubscriptPair
Dim Xp As Expressionist
Dim Uni As UnaryExpression
Dim Bin As BinaryExpression

If InsideProc Then: If Access = acPublic Or Access = acPrivate Then Fail Token, Msg063
If Token Is Nothing Then Set Token = NextToken

Set Xp = New Expressionist
Xp.CanHaveTo = True

Do
Set Var = New Variable
Var.Access = Access

If Token.IsKeyword(kwWithEvents) Then
If Not Entity.IsClass Then Fail Token, Msg016
If InsideProc Then Fail Token, Msg063

Var.HasWithEvents = True
Set Token = NextToken
End If

If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, Msg061, Msg003
Set Var.Id.Name = Token

Set Token = NextToken
WasArray = False

If Token.Kind = tkLeftParenthesis Then
Do
Set Expr = Xp.GetExpression(Me)
Set Token = Xp.LastToken

If Not Expr Is Nothing Then
Select Case Expr.Kind
Case ekLiteral, ekSymbol, ekUnaryExpr
Set Subs = New SubscriptPair
Set Subs.LowerBound = SynthLower(Entity)
Set Subs.UpperBound = Expr

Case ekBinaryExpr
Set Bin = Expr
Set Subs = New SubscriptPair

If Bin.Operator.Value.IsOperator(opTo) Then
Set Subs.LowerBound = Bin.LHS
Set Subs.UpperBound = Bin.RHS
Else
Set Subs.LowerBound = SynthLower(Entity)
Set Subs.UpperBound = Expr
End If

Case Else
Fail Token, Msg065
End Select

Var.Subscripts.Add Subs
End If

If Token.Kind <> tkListSeparator Then Exit Do
Loop

If Token.Kind <> tkRightParenthesis And Xp.LastToken.Kind <> tkRightParenthesis Then Fail Token, Msg057

WasArray = True
Set Token = NextToken
End If

If Token.IsKeyword(kwAs) Then
If Var.Id.Name.Suffix <> vbNullChar Then Fail Token, Msg024
Set Token = NextToken

If Token.IsOperator(opNew) Then
Var.HasNew = True
Set Token = NextToken
End If

If Not IsProperDataType(Token) Then Fail Token, Msg061, Msg025
Set Var.DataType = NewDataType(Token)

If Var.HasNew And Var.DataType.Id.Name.Kind = tkKeyword Then Fail Token, Msg062, Msg059

Set Token = NextToken

If Token.IsOperator(opDot) Then
Set Token = NextToken

If Not IsProperDataType(Token) Then Fail Token, Msg061, Msg003
Set Var.DataType.Id.Name = Token

Set Token = NextToken
End If

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

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

If Token.IsOperator(opMul) Then
Set Var.DataType.FixedLength = Xp.GetExpression(Me)
Set Token = Xp.LastToken
End If

Var.DataType.IsArray = WasArray
If Var.HasNew And Var.DataType.IsArray Then Fail Token, Msg064

If Token.IsOperator(opEq) Then
Set Var.Init = Xp.GetExpression(Me)
Set Token = Xp.LastToken
End If

Name = NameOf(Var.Id.Name)
CheckDupl Entity, Var.Id.Name
Entity.Vars.Add Var, Name

If IsBreak(Token) Then Exit Do
If Token.Kind <> tkListSeparator Then Fail Token, Msg061, ","
Set Token = NextToken
Loop
End Sub

Private Sub ParseType(ByVal Access As Accessibility, ByVal Entity As Entity)
Dim Name As String
Dim Token As Token
Dim Ent As Entity
Dim Var As Variable
Dim Typ As TypeConstruct

Set Ent = New Entity
Set Typ = New TypeConstruct
Typ.Access = Access

Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, Msg066, Msg003

Set Typ.Id = NewId(Token)
MustEatLineBreak
Set Token = Nothing ' Force ParseDim to get next token

Do
ParseDim acLocal, Ent, Token:=Token
Rem Should not have "A As Boolean, B As ...
If Ent.Vars.Count > 1 Then Fail Ent.Vars(2).Id.Name, Msg067, Msg031

Set Var = Ent.Vars(1)
Rem Must have an explicit data type.
If Var.DataType.Id.Name.Line = 0 Then Fail Var.DataType.Id.Name, Msg067, vAs

Rem Must not have an initial value
If Not Var.Init Is Nothing Then Fail Var.Init, Msg067, Msg031

Ent.Vars.Clear
Name = NameOf(Var.Id.Name)
If Typ.Members.Exists(Name) Then Fail Var.Id.Name, Msg006 & Name

Typ.Members.Add Var, Name
Set Token = SkipLineBreaks
Loop Until Token.IsKeyword(kwEnd)

Set Token = NextToken
If Not Token.IsKeyword(kwType) Then Fail Token, Msg068, vType

Name = NameOf(Typ.Id.Name)
CheckDupl Entity, Var.Id.Name
Entity.Types.Add Typ, Name
End Sub

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

Friend 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 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
IsProperDataType = IsBuiltinDataType(Token)
End Select
End Function

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

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

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

Select Case Token.Code
Case cxObject, kwVariant
IsBuiltinDataType = True

Case Else
IsBuiltinDataType = IsConstDataType(Token)
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.IsKeyword(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
End If

IsEndOfContext = Result
End Function

Friend 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, tkDirective
Got = "#" & NameOf(Token)

Case tkWhiteSpace
Got = " "

Case tkComment, tkIntegerNumber, tkFloatNumber, tkSciNumber, tkBinaryNumber, tkOctalNumber, tkHexaNumber, _
tkString, tkDateTime
Got = Token.Text

Case tkLeftParenthesis
Got = "("

Case tkRightParenthesis
Got = ")"

Case tkHardLineBreak
Got = "line-break"

Case tkLineContinuation
Got = "line-continuation"

Case tkEndOfStream
Got = "end-of-stream"

Case tkSoftLineBreak
Got = ":"

Case tkListSeparator
Got = ","

Case tkPrintSeparator
Got = ";"

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

Private Sub CheckDupl(ByVal Entity As Entity, ByVal Token As Token, Optional ByVal JumpProp As Boolean)
Dim Name As String

Name = NameOf(Token)
If Entity.Consts.Exists(Name) Then Fail Token, Msg006 & Name
If Entity.Enums.Exists(Name) Then Fail Token, Msg006 & Name
If Entity.Declares.Exists(Name) Then Fail Token, Msg006 & Name
If Entity.Events.Exists(Name) Then Fail Token, Msg006 & Name
If Entity.Impls.Exists(Name) Then Fail Token, Msg006 & Name
If Entity.Vars.Exists(Name) Then Fail Token, Msg006 & Name
If Entity.Types.Exists(Name) Then Fail Token, Msg006 & Name
If Entity.Subs.Exists(Name) Then Fail Token, Msg006 & Name
If Entity.Functions.Exists(Name) Then Fail Token, Msg006 & Name
If Not JumpProp Then If Entity.Properties.Exists(Name) Then Fail Token, Msg006 & Name
End Sub
End Class

Public Class PrintConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snPrint
End Property
End Class

Public Class PropertyConstruct
Option Explicit

Private Parms_ As KeyedList
Private Body_ As KeyedList

Public Access As Accessibility
Public IsStatic As Boolean
Public IsDefault As Boolean

Private Sub Class_Initialize()
Set Parms_ = New KeyedList
Set Parms_.T = NewValidator(TypeName(New Parameter))
Parms_.CompareMode = vbTextCompare

Set Body_ = New KeyedList
Set Body_.T = New StmtValidator
End Sub

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

Public Static Property Get Body() As KeyedList
Set Body = Body_
End Property
End Class

Public Class PropertySlot
Option Explicit

Private PropertyGet_ As PropertyConstruct
Private PropertyLet_ As PropertyConstruct
Private PropertySet_ As PropertyConstruct

Public Id As Identifier
Public DataType As DataType

Public Sub Add(ByVal Kind As VbCallType, ByVal Item As PropertyConstruct)
Select Case Kind
Case VbGet
If Not PropertyGet_ Is Nothing Then Err.Raise 457
Set PropertyGet_ = Item

Case VbLet
If Not PropertyLet_ Is Nothing Then Err.Raise 457
Set PropertyLet_ = Item

Case VbSet
If Not PropertySet_ Is Nothing Then Err.Raise 457
Set PropertySet_ = Item

Case Else
Debug.Assert False
End Select
End Sub

Public Default Property Get Item(ByVal Kind As VbCallType) As PropertyConstruct
Select Case Kind
Case VbGet
Set Item = PropertyGet_

Case VbLet
Set Item = PropertyLet_

Case VbSet
Set Item = PropertySet_

Case Else
Debug.Assert False
End Select
End Property

Public Property Get Exists(ByVal Kind As VbCallType) As Boolean
Select Case Kind
Case VbGet
Exists = Not PropertyGet_ Is Nothing

Case VbLet
Exists = Not PropertyLet_ Is Nothing

Case VbSet
Exists = Not PropertySet_ Is Nothing

Case Else
Debug.Assert False
End Select
End Property
End Class

Public Class PutConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snPut
End Property
End Class

Public Class RaiseEventConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snRaiseEvent
End Property
End Class

Public Class ReDimConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snReDim
End Property
End Class

Public Class ResetConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snReset
End Property
End Class

Public Class ResumeConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snResume
End Property
End Class

Public Class ReturnConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snReturn
End Property
End Class

Public Class RSetConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snRSet
End Property
End Class

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 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 BS_ As Integer = 8 ' Backspace. Used for line continuation
Private Const CRLF_ As Long = &HA000D

Public Enum KeywordNumbers
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
kwIterator ' 61
kwLet ' 62
kwLocal ' 63
kwLong ' 64
kwLongLong ' 65
kwLongPtr ' 66
kwLoop ' 67
kwLSet ' 68
kwMe ' 69
kwModule ' 70
kwNext ' 71
kwNothing ' 72
kwNull ' 73
kwOn ' 74
kwOpen ' 75
kwOption ' 76
kwOptional ' 77
kwParamArray ' 78
kwPreserve ' 79
kwPrint ' 80
kwPrivate ' 81
kwPSet ' 82
kwPublic ' 83
kwPut ' 84
kwRaiseEvent ' 85
kwReDim ' 86
kwRem ' 87
kwResume ' 88
kwReturn ' 89
kwRSet ' 90
kwScale ' 91
kwSeek ' 92
kwSelect ' 93
kwSet ' 94
kwSingle ' 95
kwStatic ' 96
kwStop ' 97
kwString ' 98
kwSub ' 99
kwThen ' 100
kwTo ' 101
kwTrue ' 102
kwType ' 103
kwUnlock ' 104
kwUntil ' 105
kwVariant ' 106
kwVoid ' 107
kwWend ' 108
kwWhile ' 109
kwWith ' 110
kwWithEvents ' 111
kwWrite ' 112
End Enum

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

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

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

RunningLine_ = 0
RunningColumn_ = 1

Set Ids_ = New KeyedList
Set Ids_.T = NewValidator("String")
Ids_.CompareMode = vbTextCompare

Set Keywords_ = New KeyedList
Set Keywords_.T = NewValidator("String")
Keywords_.CompareMode = vbTextCompare

Rem 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, _
vIterator, 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
Set Contextuals_.T = NewValidator("String")
Contextuals_.CompareMode = vbTextCompare
Values = Array(vAccess, vAlias, vAppend, vBase, vBinary, vCompare, vDecimal, vError, vExplicit, vLen, vLib, 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
Set Operators_.T = NewValidator("String")
Operators_.CompareMode = vbTextCompare
Rem Operator order must follow the Enum's one.
Values = Array(vAddressOf, vAndAlso, vByVal, vIs, vIsNot, vLike, vNew, vNot, vOrElse, vTo, 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_

Rem 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 Until 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 ' CodePoint >> 8
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(kwInteger)
If Character = vbBack Then Length = Length * 2 + Len(vbNewLine) * SizeOf(kwInteger)
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 "%", "&", "^", "@", "!", "#", "$"
Rem 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
Rem 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 "_"
Rem 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 "_"
Rem 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 "_"
Rem 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 "_"
Rem 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

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

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

Select Case UCase$(Name)
Case UCase$(vIf), UCase$(vElseIf), UCase$(vElse), UCase$(vEnd), UCase$(vConst)
Rem 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
Rem Not a month name, we have a variable file-handle instead.
Rem 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

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

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

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

Rem 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

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

If Err.Number Then
Rem 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 " "
Rem 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 "#"
Rem 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

Rem 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

Rem Validate year.
If YYYY > 9999 Then Fail Msg

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

Rem 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

Rem 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

Rem 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

Rem 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"
Rem 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 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 SeekConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snSeek
End Property
End Class

Public Class SelectConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snSelect
End Property
End Class

Public Class SetConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snSet
End Property
End Class

Public Class SourceFile
Option Explicit

Private Entities_ As KeyedList

Public Path As String

Private Sub Class_Initialize()
Set Entities_ = New KeyedList
Set Entities_.T = NewValidator(TypeName(New Entity))
Entities_.CompareMode = vbTextCompare
End Sub

Public Static Property Get Entities() As KeyedList
Set Entities = Entities_
End Property
End Class

Public Class StmtValidator
Option Explicit
Implements IKLValidator

Private Function IKLValidator_Validate(ByVal Item As Variant) As Boolean
IKLValidator_Validate = TypeOf Item Is IStmt
End Function
End Class

Public Class StopConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snStop
End Property
End Class

Public Class SubConstruct
Option Explicit

Private Parms_ As KeyedList
Private Body_ As KeyedList

Public Access As Accessibility
Public IsStatic As Boolean
Public IsDefault As Boolean
Public Id As Identifier

Private Sub Class_Initialize()
Set Parms_ = New KeyedList
Set Parms_.T = NewValidator(TypeName(New Parameter))
Parms_.CompareMode = vbTextCompare

Set Body_ = New KeyedList
Set Body_.T = New StmtValidator
End Sub

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

Public Static Property Get Body() As KeyedList
Set Body = Body_
End Property
End Class

Public Class SubscriptPair
Option Explicit

Private UpperBound_ As IExpression

Public LowerBound As IExpression

Public Property Get UpperBound() As IExpression
Set UpperBound = UpperBound_
End Property

Public Property Set UpperBound(ByVal Value As IExpression)
If Not UpperBound_ Is Nothing Then Set LowerBound = UpperBound_
Set UpperBound_ = Value
End Property
End Class

Public Class Symbol
Option Explicit
Implements IExpression

Public Value As Token

Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekSymbol
End Property
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

Public Function IsKeyword(ByVal Code As Long) As Boolean
If Kind <> tkKeyword Then Exit Function
If Me.Code <> Code Then Exit Function
IsKeyword = True
End Function

Public Function IsOperator(ByVal Code As Long) As Boolean
If Kind <> tkOperator Then Exit Function
If Me.Code <> Code Then Exit Function
IsOperator = True
End Function
End Class

Public Class TupleConstruct
Option Explicit
Implements IExpression

Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekTuple
End Property

Public Static Property Get Elements() As KeyedList
Dim Hidden As New KeyedList

Set Elements = Hidden
End Property
End Class

Public Class TypeConstruct
Option Explicit

Private Members_ As KeyedList

Public Access As Accessibility
Public Id As Identifier

Private Sub Class_Initialize()
Set Members_ = New KeyedList
Set Members_.T = NewValidator(TypeName(New Variable))
Members_.CompareMode = vbTextCompare
End Sub

Public Property Get Members() As KeyedList
Set Members = Members_
End Property
End Class

Public Class UnaryExpression
Option Explicit
Implements IExpression

Public Operator As Operator
Public Value As IExpression

Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekUnaryExpr
End Property
End Class

Public Class UnlockConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snUnlock
End Property
End Class

Public Class Variable
Option Explicit

Private Subscripts_ As KeyedList

Public Access As Accessibility
Public IsStatic As Boolean
Public HasWithEvents As Boolean
Public HasNew As Boolean
Public DataType As DataType
Public Init As IExpression

Private Sub Class_Initialize()
Set Subscripts_ = New KeyedList
Set Subscripts_.T = NewValidator(TypeName(New SubscriptPair))
End Sub

Public Static Property Get Id() As Identifier
Dim Hidden As New Identifier
Set Id = Hidden
End Property

Public Static Property Get Subscripts() As KeyedList
Set Subscripts = Subscripts_
End Property
End Class

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

Rem Copy structure to the allocated memory
CopyMemory Destination:=ByVal Ptr, Source:=VarPtr(Obj), Length:=Len(Obj)
Rem 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

Public Class WhileConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snWhile
End Property
End Class

Public Class WidthConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snWidth
End Property
End Class

Public Class WithConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snWith
End Property
End Class

Public Class WriteConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snWrite
End Property
End Class