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

Let's build a transpiler! Part 45

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

The acupuncturist programmer

So, I used to work with this guy, let's call him Ronald. We were a team of maybe 15 developers.
We had development to do, but we were also in charge of tickets, meaning we needed to fix any bugs our customers found. And there was a lot to be found.
To give you an idea, on the database side - that I was responsible for - I had a big stored procedure that I would run on a day-to-day basis. It would spit lots and lots of inconsistencies, to which I would respond manually updating several tables to fix them. I used to do that because I could not find what was causing the issues in the first place. My boss at the time was OK with that. Not that he accepted that easily. I mentioned to him one day that there were lots of issues every day to be fixed. He then promptly forgot about it and not long after that, he told me, kind of annoyed, that he did not know there were so many problems. That prompted me to send him a daily e-mail with the "report" produced by that stored procedure. After a few weeks of that, he gently asked me to be removed from the e-mail's CC.

But, tickets. My approach was similar to any other dev: Read the description, try to reproduce the issue, figure out what was wrong, figure out what was supposed to happen, figure out how to turn the previous into the latter, and make it happen.

The thing is, while working on the code, often I would find even more bugs sitting there waiting to happen. And I would fix them. After all, that's what I was being paid for, right?

As it seems, it wasn't. One of my bosses (I had three at the time) complained that I was slow. I should close more tickets. But, but, but... all those bugs!

Then one day Ronald shared a gem of wisdom. He said that when fixing a bug, he would go there and work on that specific bug, nothing more, nothing less. It didn't matter there might be dragons there. It only poked that tiny piece of software. Like an acupuncturist: A little sting and the job was done. That couple of lines right there that would reformat the user's hard drive if the wrong phase of the Moon occurred during the Super Bowl break? Let the user report it. There would be another ticket and another pinpoint fix would be done. He would be productive as always, improving the company's ERP bit by bit with his diligent work.

I have never felt more enlightened.

Back to business

So, it's been a few months since I last touched transpiler's source code.
You will not notice any gap because I have several pre-written posts.
What happened you ask? Life. Something showed up, I had to put the transpiler aside, worked on that something to disappointingly no profit, then I went back.

I still intend to validate things, so I did what I have done before: Try something, figure out it does not work, try something else just to see it pours bugs like a hive on fire, rinse and repeat.
Then, somehow, I tried an approach that worked. I relied heavily on my PINQ's Where procedure. But it is slow. Like, slow.

To give you an idea, parsing transpiler's own code takes around 14 seconds. Validating and reverting takes around 20 seconds.
And then VB6 IDE takes another 37 seconds to let it go. I suppose there's a lot of memory to free, that's why Visual Studio is taking its sweet time, but I'm not sure.
All in all, it takes around 1:11 each time I run the code... Not good. I'll try to have Where be faster, but I don't know.

The focus was on the ValidateExpr method. You should take a look at it and all methods it uses (FindRowType and folks.)
By the way, these are some modifications I did: In the long run, I fear this will crumble horribly, but I'm still to figure out how to handle this properly.

And that's it. Next week, I'll try to fix the remaining issues in this code's version.

Andrej Biasic
2021-07-28

Public Class AEIOU
Option Explicit

'Assessment: Exists / Is Of Use
Public Name As String
Public IsDeclared As Boolean
Public IsUsed As Boolean
Public Token As Token
End Class


Public Class AttributeConstruct
Option Explicit

Public Id As Identifier
Public Value As IExpression
End Class


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

Private Arguments_ As KeyedList

Public LHS As IExpression

Private Sub Class_Initialize()
Set Arguments_ = New KeyedList
Set Arguments_.T = New ExprValidator
End Sub

Public Property Get Arguments() As KeyedList
Set Arguments = Arguments_
End Property

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

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


Public Class CaseConstruct
Option Explicit

Private Conditions_ As KeyedList
Private Body_ As KeyedList

Private Sub Class_Initialize()
Set Conditions_ = New KeyedList
Set Conditions_.T = New ExprValidator

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

Public Property Get Conditions() As KeyedList
Set Conditions = Conditions_
End Property

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


Public Class CloseConstruct
Option Explicit
Implements IStmt

Private FileNumbers_ As KeyedList

Private Sub Class_Initialize()
Set FileNumbers_ = New KeyedList
Set FileNumbers_.T = New ExprValidator
End Sub

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

Public Property Get FileNumbers() As KeyedList
Set FileNumbers = FileNumbers_
End Property
End Class


Public Class ConstConstruct
Option Explicit
Implements IStmt

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

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


Public Class ContinueConstruct
Option Explicit
Implements IStmt

Public Enum ContinueWhat
cwDo
cwFor
cwWhile
End Enum

Public What As ContinueWhat

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


Public Class ControlPanel
Option Explicit

Private Targets_ As KeyedList
Private Vars_ As KeyedList
Private Consts_ As KeyedList

Public HadDim As Boolean
Public HadArray As Boolean
Public BodyType As Long
Public DoCount As Long
Public ForCount As Long
Public WhileCount As Long
Public SelectCount As Long
Public Entity As Entity
Public Method As IMethod

Private Sub Class_Initialize()
Set Targets_ = New KeyedList
Set Targets_.T = NewValidator(TypeName(New AEIOU))
Targets_.CompareMode = vbTextCompare

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

Set Consts_ = New KeyedList
Set Consts_.T = NewValidator(TypeName(New AEIOU))
Consts_.CompareMode = vbTextCompare
End Sub

Public Sub AddTarget(ByVal Target As Variant)
Dim Idx As Long
Dim Key As String
Dim A As AEIOU
Dim Tkn As Token
Dim Lbl As LabelConstruct
Dim Lin As LineNumberConstruct

If TypeOf Target Is LabelConstruct Then
Set Lbl = Target
Set Tkn = Lbl.Id.Name
Key = "Label " & NameBank(Tkn)
Else
Set Lin = Target
If Lin.Value.Text = "+0" Then Exit Sub
Set Tkn = Lin.Value
Key = "Line number " & CLng(Tkn.Text)
End If

Idx = Targets_.IndexOf(Key)

If Idx = 0 Then
Set A = New AEIOU
A.Name = Key
Set A.Token = Tkn
A.IsUsed = True
Targets_.Add A, Key
Else
Set A = Targets_(Idx)
A.IsUsed = True
End If
End Sub

Public Sub AddLine(ByVal LineNumber As LineNumberConstruct)
Dim Idx As Long
Dim Key As String
Dim A As AEIOU

If LineNumber.Value.Text = "+0" Then Exit Sub
Key = "Line number " & CLng(LineNumber.Value.Text)
Idx = Targets_.IndexOf(Key)

If Idx = 0 Then
Set A = New AEIOU
A.Name = Key
Set A.Token = LineNumber.Value
A.IsDeclared = True
Targets_.Add A, Key
Else
Set A = Targets_(Idx)
A.IsDeclared = True
End If
End Sub

Public Sub AddLabel(ByVal Label As LabelConstruct)
Dim Idx As Long
Dim Key As String
Dim A As AEIOU

Key = "Label " & NameBank(Label.Id.Name)
Idx = Targets_.IndexOf(Key)

If Idx = 0 Then
Set A = New AEIOU
A.Name = Key
Set A.Token = Label.Id.Name
A.IsDeclared = True
Targets_.Add A, Key
Else
Set A = Targets_(Idx)
A.IsDeclared = True
End If
End Sub

Public Sub AddVar(ByVal Parser As Parser, ByVal Var As Variant, Optional ByVal IsReDim As Boolean)
Dim Idx As Long
Dim Name As String
Dim A As AEIOU
Dim Token As Token
Dim Variable As Variable
Dim Parm As Parameter

If TypeOf Var Is Variable Then
Set Variable = Var
Set Token = Variable.Id.Name
Else
Set Parm = Var
Set Token = Parm.Id.Name
End If

Name = NameBank(Token)
Idx = Vars_.IndexOf(Name)

If Idx = 0 Then
Set A = New AEIOU
A.Name = Name
Set A.Token = Token
A.IsDeclared = True
Vars_.Add A, Name
Else
Set A = Vars_(Idx)
If A.IsDeclared And Not IsReDim Then Parser.Fail A.Token, m.Duplicated
A.IsDeclared = True
End If
End Sub

Public Sub AddConst(ByVal Parser As Parser, ByVal Constant As ConstConstruct)
Dim Idx As Long
Dim Name As String
Dim A As AEIOU

Name = NameBank(Constant.Id.Name)
Idx = Consts_.IndexOf(Name)

If Idx = 0 Then
Set A = New AEIOU
A.Name = Name
Set A.Token = Constant.Id.Name
A.IsDeclared = True
Consts_.Add A, Name
Else
Set A = Consts_(Idx)
If A.IsDeclared Then Parser.Fail A.Token, m.Duplicated
A.IsDeclared = True
End If
End Sub

Public Sub Validate(ByVal Parser As Parser, ByVal Entity As Entity)
Dim A As AEIOU

For Each A In Targets_
If Not A.IsDeclared Then
Parser.Fail A.Token, A.Name & " does not exist"

ElseIf Not A.IsUsed Then
Parser.Fail A.Token, A.Name & " is not used"
End If
Next

For Each A In Vars_
If Not A.IsDeclared Then
If Entity.OptionExplicit Then Parser.Fail A.Token, "Variable not defined"
Rem TODO: Synth variable declaration.

ElseIf Not A.IsUsed Then
'Debug.Print "[File: '" & Parser.SourceFile.Path & _
"', line: "; A.Token.Line & _
", column: " & A.Token.Column & _
"] Variable not used: " & A.Name
End If
Next
End Sub
End Class


Public Class DataType
Option Explicit

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


Public Class Debug
Option Explicit

Public Sub Assert(ByRef Condition As Boolean)
#If DebugBuild Then
If Condition Then Exit Sub
Beep
Stop
#End If
End Sub

Public Sub [Print](ParamArray Args())
End Sub
End Class


Public Class DebugConstruct
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
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
Rem It should not happen
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

Public Enum DoWhat
dtNone
dtDoLoop
dtDoWhileLoop
dtDoUntilLoop
dtDoLoopWhile
dtDoLoopUntil
End Enum

Private Body_ As KeyedList

Public Condition As IExpression
Public DoType As DoWhat

Private Sub Class_Initialize()
Set Body_ = New KeyedList
Set Body_.T = New StmtValidator
End Sub

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

Public Property Get Body() As KeyedList
Set Body = Body_
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
Private Attributes_ As KeyedList

Public OptionBase As Integer
Public OptionCompare As VbCompareMethod
Public OptionExplicit As Boolean
Public IsClass As Boolean
Public Access 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

Set Attributes_ = New KeyedList
Set Attributes_.T = NewValidator(TypeName(New AttributeConstruct))
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

Public Property Get Attributes() As KeyedList
Set Attributes = Attributes_
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 Vars_ As KeyedList

Private Sub Class_Initialize()
Set Vars_ = New KeyedList
Set Vars_.T = NewValidator(TypeName(New Symbol))
End Sub

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

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


Public Class ErrObject
Option Explicit

Public Description As String
Public HelpContext As Long
Public HelpFile As String
Public Source As String

Public Sub Clear()
End Sub

Public Property Get LastDllError() As Long
End Property

Public Default Property Get Number() As Long
End Property

Public Property Let Number(ByRef Value As Long)
End Property

Public Sub Raise( _
ByRef Number As Long, _
Optional ByRef Source As Variant, _
Optional ByRef Description As Variant, _
Optional ByRef HelpFile As Variant, _
Optional ByRef HelpContext As Variant _
)
End Sub
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

Public Enum ExitWhat
ewDo
ewFor
ewFunction
ewProperty
ewSelect
ewSub
ewWhile
End Enum

Public What As ExitWhat

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 FullMode 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, Optional ByVal Token As Token) As IExpression
Dim HadTo As Boolean
Dim WantOperand As Boolean
Dim Cp As Integer
Dim Count As Integer
Dim Name As String
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
Dim Args As TupleConstruct

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

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

WantOperand = True

Do
If Token Is Nothing Then Set Token = Parser.NextToken

If WantOperand Then
WantOperand = False

Select Case Token.Kind
Case tkOperator
Select Case Token.Code
Case opAddressOf, opAndAlso, opByVal, opIs, opIsNot, opLike, opNew, opNot, opOrElse, opTo, _
opTypeOf, opAnd, opEqv, opImp, opMod, opOr, opXor
GoSub CheckDowngrade
End Select

Rem This check is not redundant. It is verifying if the call to CheckDowngrade reclassified Token.
If Token.Kind = tkOperator Then
Count = Count + IIf(Count < 0, -1, 1)

Select Case Token.Code
Case opSum
Token.Code = opIdentity

Case opSubt
Token.Code = opNeg

Rem Unary operator
Case opNew
Select Case Count
Case -2, 1
Rem OK

Case Else
Parser.Fail Token, m.InvUseOf & NameBank(Token)
End Select

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

Case opDot
Token.Code = opWithDot

Case opBang
Token.Code = opWithBang

Case Else
Exit Do
End Select

WantOperand = True
Set Op = NewOperator(Token)
OpStack.Add Op
End If

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

Case tkIdentifier, tkEscapedIdentifier, tkCrazyIdentifier
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 kwInput, kwSeek
Set Sym = New Symbol
Set Sym.Value = Token
OutStack.Add Sym

Case kwByVal
Token.Kind = tkOperator
Token.Code = opByVal
GoTo Down

Case Else
GoSub CheckDowngrade
If Token.Kind = tkKeyword Then 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
Down:
Count = Count + IIf(Count < 0, -1, 1)

Rem Unary and compound operators
Select Case Token.Code
Case opNamed
If Count <> 1 Then Parser.Fail Token, m.InvUseOf & NameBank(Token)
Count = -1

Case opByVal
Select Case Count
Case -2, 1
Rem OK

Case Else
Parser.Fail Token, m.InvUseOf & NameBank(Token)
End Select

Case opAddressOf, opNew, opNot, opTypeOf
Parser.Fail Token, m.InvExpr

Case opCompAnd, opCompEqv, opCompImp, _
opCompMod, opCompOr, opCompXor, opCompSum, opCompSubt, opCompMul, opCompDiv, _
opCompIntDiv, opCompPow, opCompLSh, opCompRSh, opCompURSh, opCompConcat
Exit Do
End Select

Set Op = NewOperator(Token)

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

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

OpStack.Add Op
WantOperand = True

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

Move OpStack, OutStack, Op
Loop

Rem It is allowed to not have a "(" on OpStack because we can be evaluating the following:
Rem Sub A(Optional B As Integer = 1)
Rem We'll get to ")" without having ")" on stack.
If OpStack.Count = 0 Then Exit Do
Pop OpStack

Case tkKeyword
If Token.Code <> kwTo Then Exit Do

If CanHaveTo Imp HadTo Then Err.Raise vbObjectError + 13
HadTo = True

Token.Kind = tkOperator
Token.Code = NameBank.Operators.IndexOf(v.To)
GoTo Down

Case tkLeftParenthesis
If Not FullMode Then Exit Do

Token.Kind = tkOperator
Token.Code = opApply
OpStack.Add NewOperator(Token)

Set Args = New TupleConstruct
Set Token = CollectArgs(Args.Elements, Parser)
If Token.Kind <> tkRightParenthesis Then Debug.Assert False 'TODO: Error
OutStack.Add Args

Case Else
Exit Do
End Select
End If

Set Token = Nothing
Loop

Set LastToken_ = Token

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

Move OpStack, OutStack, Op
Loop

Debug.Assert OpStack.Count = 0
Debug.Assert OutStack.Count <= 1
If OutStack.Count = 1 Then Set GetExpression = Pop(OutStack)
Exit Function

CheckDowngrade:
If Op Is Nothing Then Return
If Op.IsUnary Or Op.Value.Code <> opDot And Op.Value.Code <> opBang Then Return
Parser.EnsureIdExists Token

Set Sym = New Symbol
Set Sym.Value = Token
OutStack.Add Sym
Return
End Function

Private Sub Move(ByVal OpStack As KeyedList, ByVal OutStack As KeyedList, Optional ByVal Op As Operator)
Dim Elem As Variant
Dim Token As Token
Dim Lit As Literal
Dim IExpr As IExpression
Dim Exec As CallConstruct
Dim Tup As TupleConstruct
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
'----------------------------------------------------------------------------------------------------
If Uni.Operator.Value.Code = opNeg And Uni.Value.Kind = ekLiteral Then
Set Lit = Uni.Value

Select Case Lit.Value.Kind
Case tkIntegerNumber, tkFloatNumber, tkSciNumber, tkBinaryNumber, tkOctalNumber, tkHexaNumber
Set Token = Lit.Value

If Left$(Token.Text, 1) = "+" Then
Token.Text = "-" & Mid$(Token.Text, 2)
Else
Token.Text = "+" & Mid$(Token.Text, 2)
End If

Select Case Token.Suffix
Case 0, vbInteger, vbLong, vbLongLong, vbDouble
Select Case Token.Kind & Token.Text
Case tkIntegerNumber & "-32768", _
tkBinaryNumber & "-1000000000000000", _
tkOctalNumber & "-100000", _
tkHexaNumber & "-8000"
Token.Code = vbInteger

Case tkIntegerNumber & "+32768", _
tkBinaryNumber & "+1000000000000000", _
tkOctalNumber & "+100000", _
tkHexaNumber & "+8000", _
tkIntegerNumber & "-2147483648", _
tkBinaryNumber & "-10000000000000000000000000000000", _
tkOctalNumber & "-20000000000", _
tkHexaNumber & "-80000000"
Token.Code = vbLong

Case tkIntegerNumber & "+2147483648", _
tkBinaryNumber & "+10000000000000000000000000000000", _
tkOctalNumber & "+20000000000", _
tkHexaNumber & "+80000000", _
tkIntegerNumber & "-9223372036854775808", _
tkBinaryNumber & "-1000000000000000000000000000000000000000000000000000000000000000", _
tkOctalNumber & "-1000000000000000000000", _
tkHexaNumber & "-8000000000000000"
Token.Code = vbLongLong

Case tkIntegerNumber & "+9223372036854775808", _
tkBinaryNumber & "+1000000000000000000000000000000000000000000000000000000000000000", _
tkOctalNumber & "+1000000000000000000000", _
tkHexaNumber & "+8000000000000000"
Token.Code = vbDouble
End Select
End Select

Set IExpr = Lit
End Select
End If
'----------------------------------------------------------------------------------------------------

ElseIf Op.Value.Code = opApply Then
Set Exec = New CallConstruct
Set Tup = Pop(OutStack)

For Each Elem In Tup.Elements
Exec.Arguments.Add Elem
Next

Set Exec.LHS = Pop(OutStack)
Set IExpr = Exec

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

Public Function GetStmt(ByVal Parser As Parser, Optional ByVal Token As Token, Optional ByVal LookAhead As Token) As IStmt
Dim Done As Boolean
Dim Result As IStmt
Dim Sym As Symbol
Dim Name As IExpression
Dim Asg As LetConstruct
Dim Xp As Expressionist
Dim Exec As CallConstruct
Dim Uni As UnaryExpression
Dim Bin As BinaryExpression

Set Xp = New Expressionist

If Token Is Nothing Then Set Token = Parser.NextToken

If Token.Kind = tkOperator Then
If Token.Code = opWithBang Or Token.Code = opWithDot Then
Set Uni = New UnaryExpression
Set Uni.Operator = NewOperator(Token)
Set Token = Parser.NextToken
If Token.Kind <> tkIdentifier And Token.Kind <> tkEscapedIdentifier Then Stop

Set Sym = New Symbol
Set Sym.Value = Token
Set Uni.Value = Sym
Set Name = Uni
Else
Stop
End If
End If

If Name Is Nothing Then
Set Sym = New Symbol
Set Sym.Value = Token
Set Name = Sym
End If

If LookAhead Is Nothing Then
Set Token = Parser.NextToken
Else
Set Token = LookAhead
End If

Do
Done = True

Select Case Token.Kind
Case tkLeftParenthesis
Set Exec = New CallConstruct
Set Exec.LHS = Name
Set Token = CollectArgs(Exec.Arguments, Parser)
If Token.Kind = tkRightParenthesis Then Set Token = Parser.NextToken
Set Name = Exec
Rem Let's iterate again
Done = False

Case tkOperator
Select Case Token.Code
Case opAddressOf, opNew, opNot, opTypeOf, opWithDot, opWithBang
Rem Operator is being passed to CollectArgs through Token argument.
Set Exec = New CallConstruct
Set Exec.LHS = Name
Set Token = CollectArgs(Exec.Arguments, Parser, Token)
Set Result = Exec

Case opDot
Set Bin = New BinaryExpression
Set Bin.Operator = NewOperator(Token)
Set Bin.LHS = Name

Set Token = Parser.NextToken

If Token.Kind <> tkIdentifier And _
Token.Kind <> tkEscapedIdentifier And _
Token.Kind <> tkCrazyIdentifier _
Then Exit Do

Set Sym = New Symbol
Set Sym.Value = Token
Set Bin.RHS = Sym

Set Name = Bin

Set Token = Parser.NextToken
Done = False

Case opEq
Set Asg = New LetConstruct
Set Asg.Operator = NewOperator(Token)
Set Asg.Name = Name

Xp.FullMode = True
Set Asg.Value = Xp.GetExpression(Parser)
Set Token = Xp.LastToken
If Asg.Value Is Nothing Then Exit Do

Set Result = Asg

Case opSum
Rem Identity operator. We'll ignore it.
Set Exec = New CallConstruct
Set Exec.LHS = Name
Set Token = CollectArgs(Exec.Arguments, Parser)
Set Result = Exec

Case opSubt
Rem Operator is being passed to CollectArgs through Token argument.
Token.Code = opNeg
Set Exec = New CallConstruct
Set Exec.LHS = Name
Set Token = CollectArgs(Exec.Arguments, Parser, Token)
Set Result = Exec

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

Set Asg = New LetConstruct
Set Asg.Operator = NewOperator(Token)
Set Asg.Name = Name

Xp.FullMode = True
Set Asg.Value = Xp.GetExpression(Parser)
Set Token = Xp.LastToken
If Asg.Value Is Nothing Then Exit Do 'We'll return Nothing to sign a problem.

Set Result = Asg
End Select

Case tkIdentifier, tkEscapedIdentifier
Set Exec = New CallConstruct
Set Exec.LHS = Name

Rem Identifier is being passed to CollectArgs through Token
Set Token = CollectArgs(Exec.Arguments, Parser, Token)
Set Result = Exec

Case tkKeyword
Rem Keyword is being passed to CollectArgs through Token
Select Case Token.Code
Case kwByVal
Set Exec = New CallConstruct
Set Exec.LHS = Name
Set Token = CollectArgs(Exec.Arguments, Parser, Token)
Set Result = Exec

Case kwDate, kwString
Token.Kind = tkIdentifier
Set Exec = New CallConstruct
Set Exec.LHS = Name
Set Token = CollectArgs(Exec.Arguments, Parser, Token)
Set Result = Exec

Case kwEmpty, kwFalse, kwMe, kwNothing, kwNull, kwTrue
Set Exec = New CallConstruct
Set Exec.LHS = Name
Set Token = CollectArgs(Exec.Arguments, Parser, Token)
Set Result = Exec

Case Else
Exit Do
End Select

Case tkIntegerNumber, tkFloatNumber, tkSciNumber, tkBinaryNumber, _
tkOctalNumber, tkHexaNumber, tkString, tkDateTime
Set Exec = New CallConstruct
Set Exec.LHS = Name
Rem Literal is being passed to CollectArgs through Token
Set Token = CollectArgs(Exec.Arguments, Parser, Token)
Set Result = Exec

Case tkListSeparator
Set Exec = New CallConstruct
Set Exec.LHS = Name
Set Token = CollectArgs(Exec.Arguments, Parser, Token)
Set Result = Exec

Case Else
If Not Parser.IsBreak(Token) Then Exit Do

If Name.Kind = ekIndexer Then
Set Exec = Name
Else
Rem Method call with no arguments.
Set Exec = New CallConstruct
Set Exec.LHS = Name
End If

Set Result = Exec
End Select
Loop Until Done

Set LastToken_ = Token
Debug.Assert Parser.IsBreak(Token) Or Token.Code = kwElse
Set GetStmt = Result
End Function

Friend Function CollectArgs(ByVal Args As KeyedList, ByVal Parser As Parser, Optional ByVal Token As Token) As Token
Dim Tkn As Token
Dim Lit As Literal
Dim Expr As IExpression
Dim Xp As Expressionist

Set Xp = New Expressionist
Xp.FullMode = True

If Not Token Is Nothing Then
If Token.Kind = tkListSeparator Then
Token.Kind = tkKeyword
Token.Code = kwVoid

Set Lit = New Literal
Set Lit.Value = Token

Args.Add Lit
Set Token = Nothing
End If
End If

Do
Set Expr = Xp.GetExpression(Parser, Token)
Set Token = Xp.LastToken
Set LastToken_ = Token

If Expr Is Nothing Then
Select Case Token.Kind
Case tkRightParenthesis
Exit Do

Case tkListSeparator
Set Tkn = New Token
Tkn.Column = Token.Column
Tkn.Line = Token.Line
Tkn.Kind = tkKeyword
Tkn.Code = kwVoid

Set Lit = New Literal
Set Lit.Value = Tkn
Set Expr = Lit

Case Else
Parser.Fail Token, m.InvExpr
End Select
End If

Args.Add Expr

If Token.Kind = tkRightParenthesis Then Exit Do
If Token.Kind <> tkListSeparator Then Exit Do
Set Token = Nothing
Loop

Set CollectArgs = Token
End Function
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 Field
Option Explicit

Public Default Name As String
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 FileTextBuilder
Option Explicit
Implements ITextBuilder

Private IsNewLine_ As Boolean
Private Indent_ As Integer
Private Handle_ As Integer

Public Property Let FilePath(ByVal Value As String)
Handle_ = FreeFile
Open Value For Output Access Write As Handle_
End Property

Private Sub Class_Terminate()
Close Handle_
End Sub

Private Sub ITextBuilder_Append(ByVal Text As String)
If IsNewLine_ Then
Print #Handle_, vbNewLine;
If Indent_ > 0 Then Print #Handle_, String$(Indent_, vbTab);
End If

IsNewLine_ = False
Print #Handle_, Text;
End Sub

Private Sub ITextBuilder_AppendLn(Optional ByVal Text As String)
If Text = "" Then
If IsNewLine_ Then Print #Handle_, vbNewLine;
Else
ITextBuilder_Append Text
End If

IsNewLine_ = True
End Sub

Private Sub ITextBuilder_Deindent()
Indent_ = Indent_ - 1
End Sub

Private Sub ITextBuilder_Indent()
Indent_ = Indent_ + 1
End Sub
End Class


Public Class ForConstruct
Option Explicit
Implements IStmt

Private Body_ As KeyedList

Public Counter As Symbol
Public StartValue As IExpression
Public EndValue As IExpression
Public Increment As IExpression

Private Sub Class_Initialize()
Set Body_ = New KeyedList
Set Body_.T = New StmtValidator
End Sub

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

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


Public Class ForEachConstruct
Option Explicit
Implements IStmt

Private Body_ As KeyedList

Public Element As Symbol
Public Group As IExpression

Private Sub Class_Initialize()
Set Body_ = New KeyedList
Set Body_.T = New StmtValidator
End Sub

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

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


Public Class FunctionConstruct
Option Explicit
Implements IMethod

Private Parms_ As KeyedList
Private Body_ As KeyedList
Private Attributes_ 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

Set Attributes_ = New KeyedList
Set Attributes_.T = NewValidator(TypeName(New AttributeConstruct))
End Sub

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

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

Public Property Get Attributes() As KeyedList
Set Attributes = Attributes_
End Property

Private Property Get IMethod_Access() As Accessibility
IMethod_Access = Access
End Property

Private Property Get IMethod_DataType() As DataType
Set IMethod_DataType = DataType
End Property

Private Property Get IMethod_Id() As Identifier
Set IMethod_Id = Id
End Property

Private Property Get IMethod_Kind() As VbCallType
IMethod_Kind = VbMethod
End Property

Private Property Get IMethod_Parameters() As KeyedList
Set IMethod_Parameters = Parms_
End Property
End Class


Public Class GetConstruct
Option Explicit
Implements IStmt

Public FileNumber As IExpression
Public RecNumber As IExpression
Public Var As Symbol

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


Public Class GoSubConstruct
Option Explicit
Implements IStmt

Public Target As IStmt

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


Public Class GoToConstruct
Option Explicit
Implements IStmt

Public Target As 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 IEnumVARIANT
Option Explicit

Public Sub Clone(ByRef ppEnum As IEnumVARIANT)
End Sub

Public Sub [Next](ByRef celt As `U´Long, ByRef rgvar As Variant, ByRef pcellFetched As `U´Long)
End Sub

Public Sub Reset()
End Sub

Public Sub Skip(ByRef celt As `U´Long)
End Sub
End Class


Public Class IExpression
Option Explicit

Public Enum ExpressionKind
ekLiteral
ekSymbol
ekFileHandle
ekTuple
ekUnaryExpr
ekBinaryExpr
ekIndexer
End Enum

Private Sub Class_Initialize()
Err.Raise 5, "IExpression.Class_Initialize"
End Sub

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


Public Class IfArm
Option Explicit

Private Body_ As KeyedList

Public Condition As IExpression

Private Sub Class_Initialize()
Set Body_ = New KeyedList
Set Body_.T = New StmtValidator
End Sub

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


Public Class IfConstruct
Option Explicit
Implements IStmt

Private Arms_ As KeyedList
Private ElseBody_ As KeyedList

Private Sub Class_Initialize()
Set Arms_ = New KeyedList
Set Arms_.T = NewValidator(TypeName(New IfArm))

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

Public Property Get Arms() As KeyedList
Set Arms = Arms_
End Property

Public Property Get ElseBody() As KeyedList
Set ElseBody = ElseBody_
End Property

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, "IKLValidator.Class_Initialize"
End Sub

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


Public Class IMethod
Option Explicit

Private Sub Class_Initialize()
Err.Raise 5, "IMethod"
End Sub

Public Property Get Kind() As VbCallType
End Property

Public Property Get Access() As Accessibility
End Property

Public Property Get Id() As Identifier
End Property

Public Property Get DataType() As DataType
End Property

Public Property Get Parameters() As KeyedList
End Property
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 Vars_ As KeyedList

Public FileNumber As IExpression

Private Sub Class_Initialize()
Set Vars_ = New KeyedList
Set Vars_.T = NewValidator(TypeName(New Symbol))
End Sub

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

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


Public Class IPictureDisp
Option Explicit

Public Default Handle As LongPtr 'OLE_HANDLE
Public Height As Long 'OLE_YSIZE_HIMETRIC
Public hPal As LongPtr 'OLE_HANDLE
Public [Type] As Integer
Public Width As Long 'OLE_XSIZE_HIMETRIC

Public Sub Render( _
ByRef hdc As Long, _
ByRef x As Long, _
ByRef y As Long, _
ByRef cx As Long, _
ByRef cy As Long, _
ByRef xSrc As Long `OLE_XPOS_HIMETRIC´, _
ByRef ySrc As Long `OLE_YPOS_HIMETRIC´, _
ByRef cxSrc As Long `OLE_XSIZE_HIMETRIC´, _
ByRef cySrc As Long `OLE_YSIZE_HIMETRIC´, _
ByRef prcWBounds As `Any´ Variant _
)
End Sub
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, "IStmt.Class_Initialize"
End Sub

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


Public Class ITextBuilder
Option Explicit

Private Sub Class_Initialize()
Err.Raise 5, "ITextBuilder.Class_Initialize"
End Sub

Public Sub Append(ByVal Text As String)
End Sub

Public Sub AppendLn(Optional ByVal Text As String)
End Sub

Public Sub Indent()
End Sub

Public Sub Deindent()
End Sub
End Class


Public Class IUnknown
Option Explicit

Public Sub QueryInterface(ByRef riid As GUID, ByRef ppvObject As LongPtr`<-Should be Any´)
End Sub

Public Function AddRef() As Long
Attribute IsCOM=False
End Function

Public Function Release() As `U´Long
Attribute IsCOM=False
End Function
End Class


Public Class IVisitor
Option Explicit

Public Enum ValidationNumbers
vnConst
vnCall
vnHandle
vnData
vnVar
vnArg
vnLet
vnSet
End Enum

Private Sub Class_Initialize()
Err.Raise 5, "IVisitor"
End Sub

Public Sub VisitSource(ByVal Source As SourceFile)
End Sub

Public Sub VisitEntity(ByVal Entity As Entity)
End Sub

Public Sub VisitAttributes(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Attrs As KeyedList)
End Sub

Public Sub VisitAccess(ByVal Access As Accessibility)
End Sub

Public Sub VisitImplements(ByVal Entity As Entity, ByVal Ipl As ImplementsConstruct)
End Sub

Public Sub VisitEvent(ByVal Entity As Entity, ByVal Evt As EventConstruct)
End Sub

Public Sub VisitId(ByVal Id As Identifier)
End Sub

Public Sub VisitParams(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Params As KeyedList)
End Sub

Public Sub VisitDataType(ByVal Entity As Entity, ByVal Method As IMethod, ByVal DataType As DataType)
End Sub

Public Sub VisitType(ByVal Entity As Entity, ByVal Typ As TypeConstruct)
End Sub

Public Sub VisitSubscripts(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Subscripts As KeyedList)
End Sub

Public Sub VisitConst(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Cnt As ConstConstruct)
End Sub

Public Sub VisitDeclare(ByVal Entity As Entity, ByVal Dcl As DeclareConstruct)
End Sub

Public Sub VisitEnum(ByVal Entity As Entity, ByVal Enm As EnumConstruct)
End Sub

Public Sub VisitExpression( _
ByVal ValidationType As ValidationNumbers, _
ByVal Entity As Entity, _
ByVal Method As IMethod, _
ByVal Expr As IExpression, _
Optional ByVal IsLHS As Boolean, _
Optional ByVal Op As Operator _
)
End Sub

Public Sub VisitBody(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Body As KeyedList)
End Sub

Public Sub VisitStmt(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As IStmt)
End Sub

Public Sub VisitCall(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As CallConstruct)
End Sub

Public Sub VisitClose(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As CloseConstruct)
End Sub

Public Sub VisitContinue(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ContinueConstruct)
End Sub

Public Sub VisitDebug(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As DebugConstruct)
End Sub

Public Sub VisitDim(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As Variable)
End Sub

Public Sub VisitDo(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As DoConstruct)
End Sub

Public Sub VisitEnd(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As EndConstruct)
End Sub

Public Sub VisitErase(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As EraseConstruct)
End Sub

Public Sub VisitExit(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ExitConstruct)
End Sub

Public Sub VisitFor(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ForConstruct)
End Sub

Public Sub VisitForEach(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ForEachConstruct)
End Sub

Public Sub VisitGet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GetConstruct)
End Sub

Public Sub VisitGoSub(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GoSubConstruct)
End Sub

Public Sub VisitGoTo(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GoToConstruct)
End Sub

Public Sub VisitIf(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As IfConstruct)
End Sub

Public Sub VisitInput(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As InputConstruct)
End Sub

Public Sub VisitLabel(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LabelConstruct)
End Sub

Public Sub VisitLet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LetConstruct)
End Sub

Public Sub VisitLineNumber(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LineNumberConstruct)
End Sub

Public Sub VisitLock(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LockConstruct)
End Sub

Public Sub VisitLSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LSetConstruct)
End Sub

Public Sub VisitName(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As NameConstruct)
End Sub

Public Sub VisitOnError(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OnErrorConstruct)
End Sub

Public Sub VisitOnComputed(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OnComputedConstruct)
End Sub

Public Sub VisitOpen(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OpenConstruct)
End Sub

Public Sub VisitPrint(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As PrintConstruct)
End Sub

Public Sub VisitPut(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As PutConstruct)
End Sub

Public Sub VisitRaiseEvent(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As RaiseEventConstruct)
End Sub

Public Sub VisitReDim(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ReDimConstruct)
End Sub

Public Sub VisitReset(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ResetConstruct)
End Sub

Public Sub VisitResume(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ResumeConstruct)
End Sub

Public Sub VisitReturn(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ReturnConstruct)
End Sub

Public Sub VisitRSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As RSetConstruct)
End Sub

Public Sub VisitSeek(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SeekConstruct)
End Sub

Public Sub VisitSelect(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SelectConstruct)
End Sub

Public Sub VisitSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SetConstruct)
End Sub

Public Sub VisitStop(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As StopConstruct)
End Sub

Public Sub VisitUnlock(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As UnlockConstruct)
End Sub

Public Sub VisitWhile(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WhileConstruct)
End Sub

Public Sub VisitWidth(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WidthConstruct)
End Sub

Public Sub VisitWith(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WithConstruct)
End Sub

Public Sub VisitWrite(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WriteConstruct)
End Sub

Public Sub VisitToken(ByVal Stmt As Token)
End Sub

Public Sub VisitOperator(ByVal Stmt As Operator)
End Sub
End Class


Public Class KeyedList
Option Explicit

Private ReadOnly_ As Boolean
Private Base_ As Integer
Private Id_ As Long
Private Count_ As Long
Private Root_ As KLNode
Private Last_ As KLNode
Private 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, Optional Before As Variant)
Const Id = "72E0DEDF0CD34921A650C8DD99F21A68_"

Dim Index As Long
Dim NewKey As String
Dim NewNode As KLNode
Dim Prev As KLNode
Dim Curr As KLNode

If ReadOnly_ Then Err.Raise 5, "KeyedList.Add"
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_
Count_ = Count_ + 1

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
Count_ = Count_ + 1

If Not IsMissing(Before) Then
If IsNumeric(Before) Then
Index = CLng(Before)
If Index > Count_ Then Index = Count_
Else
Index = IndexOf(Before)
End If

If Index < Base_ Then Index = Base_

If Index <> Count_ Then
Set Curr = Root_

Do
Index = Index - 1
If Index = 0 Then Exit Do
Set Prev = Curr
Set Curr = Curr.NextNode
Loop

If Prev Is Nothing Then
Set Root_ = NewNode
Set Root_.NextNode = Curr
Else
Set Prev.NextNode = NewNode
Set NewNode.NextNode = Curr
End If

Exit Sub
End If
End If

Set Last_.NextNode = NewNode
Set Last_ = NewNode
End If
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, "KeyedList.Item"
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, "KeyedList.Let Base"
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, "KeyedList.Let CompareMode"
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, "KeyedList.Remove"
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, "KeyedList.Remove"
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, "KeyedList.Clear"
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, "KeyedList.AddKVPairs"

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, "KeyedList.Let ReadOnly"
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

Public Id As Identifier

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


Public Class LetConstruct
Option Explicit
Implements IStmt

Public Name As IExpression
Public Operator As Operator
Public Value As IExpression

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


Public Class LineNumberConstruct
Option Explicit
Implements IStmt

Public Value As Token

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

Public FileNumber As IExpression
Public RecordRange As IExpression

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


Public Class LSetConstruct
Option Explicit
Implements IStmt

Public Name As IExpression
Public Value As IExpression

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


Public Class Messages
Option Explicit

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

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

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

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

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

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

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

Public Property Get RuleWrite() As String
RuleWrite = "Rule: Write #filenumber, [outputlist]"
End Property

Public Property Get DuplOption() As String
DuplOption = "Duplicated Option statement"
End Property

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

Public Property Get RuleEvent() As String
RuleEvent = "Rule: [Public] Event identifier [([parms])]"
End Property

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

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

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

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

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

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

Public Property Get RuleDefType() As String
RuleDefType = "Rule: DefType letter1[-letter2] [, ...]"
End Property

Public Property Get Letter1() As String
Letter1 = "letter1"
End Property

Public Property Get Letter2() As String
Letter2 = "letter2"
End Property

Public Property Get DuplDefType() As String
DuplDefType = "Duplicated Deftype statement"
End Property

Public Property Get RuleConst() As String
RuleConst = "Rule: [Public | Private] Const identifier [As datatype] = expression [, ...]"
End Property

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

Public Property Get DataType() As String
DataType = "datatype"
End Property

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

Public Property Get CommaOrEOS() As String
CommaOrEOS = "list separator or end of statement"
End Property

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

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

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

Public Property Get ExpAppendEtc() As String
ExpAppendEtc = "Expected: Append or Binary or Input or Random"
End Property

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Public Property Get ParamIsArray() As String
ParamIsArray = "ParamArray must be declared as an array of Variant"
End Property

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

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

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

Public Property Get ObjectName() As String
ObjectName = "object"
End Property

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

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

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

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

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

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

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

Public Property Get RuleWith() As String
RuleWith = "Rule: With object"
End Property

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

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

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

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

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

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

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

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

Public Property Get ExpReadWrite() As String
ExpReadWrite = "Expected: Read or Write"
End Property

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

Public Property Get PropMismatch() As String
PropMismatch = "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 ArgReqProp() As String
ArgReqProp = "Argument required for Property Let or Property Set"
End Property

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

Public Property Get DuplStatic() As String
DuplStatic = "Duplicated Static statement"
End Property

Public Property Get DuplIterator() As String
DuplIterator = "Duplicated Iterator statement"
End Property

Public Property Get DuplDefault() As String
DuplDefault = "Duplicated Default statement"
End Property

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

Public Property Get ExpEqArg() As String
ExpEqArg = "Expected: = or argument"
End Property

Public Property Get ExpEnd() As String
ExpEnd = "Expected: End "
End Property

Public Property Get ExpGLSet() As String
ExpGLSet = "Expected: " & GLSet
End Property

Public Property Get ExpStmt() As String
ExpStmt = "Expected: statement"
End Property

Public Property Get RuleIf() As String
RuleIf = "Rule: If condition Then"
End Property

Public Property Get ExpElseEtc() As String
ExpElseEtc = "Expected: Else or ElseIf or End If"
End Property

Public Property Get NonEndIf() As String
NonEndIf = "Block If without End If"
End Property

Public Property Get RuleSelect() As String
RuleSelect = "Rule: Select Case expression"
End Property

Public Property Get ExpCompOp() As String
ExpCompOp = "Expected: > or >= or = or < or <= or <>"
End Property

Public Property Get ExpIsElse() As String
ExpIsElse = "Expected: Is or Else"
End Property

Public Property Get ExpDoEtc() As String
ExpDoEtc = "Expected: Do or For or While"
End Property

Public Property Get ExpLoop() As String
ExpLoop = "Expected: Loop"
End Property

Public Property Get RuleErase() As String
RuleErase = "Rule: Erase identifier"
End Property

Public Property Get ExpDoForEtc() As String
ExpDoForEtc = "Expected: Do or For or Function or Property or Sub or Select or While"
End Property

Public Property Get RuleFor() As String
RuleFor = "Rule: For identifier = start To end [Step increment]"
End Property

Public Property Get Increment() As String
Increment = "increment"
End Property

Public Property Get ExpNext() As String
ExpNext = "Expected: Next"
End Property

Public Property Get RuleForEach() As String
RuleForEach = "Rule: For Each variable In group"
End Property

Public Property Get VariableName() As String
VariableName = "variable"
End Property

Public Property Get GroupName() As String
GroupName = "group"
End Property

Public Property Get RuleGet() As String
RuleGet = "Rule: Get [#]filenumber, [recnumber], varname"
End Property

Public Property Get WidthName() As String
WidthName = "width"
End Property

Public Property Get RulePut() As String
RulePut = "Rule: Put [#]filenumber, [recnumber], varname"
End Property

Public Property Get ExpTarget() As String
ExpTarget = "Expected: Label or line number"
End Property

Public Property Get RuleInput() As String
RuleInput = "Rule: Input #filenumber, variable[, variable, ...]"
End Property

Public Property Get HashFileNumber() As String
HashFileNumber = "#filenumber"
End Property

Public Property Get RuleWidth() As String
RuleWidth = "Rule: Width #filenumber, width"
End Property

Public Property Get RuleLock() As String
RuleLock = "Rule: Lock [#]filenumber[, recordrange]"
End Property

Public Property Get RecordRange() As String
RecordRange = "recordrange"
End Property

Public Property Get RuleLSet() As String
RuleLSet = "Rule: LSet variable = value"
End Property

Public Property Get RuleRSet() As String
RuleRSet = "Rule: RSet variable = value"
End Property

Public Property Get RuleName() As String
RuleName = "Rule: Name oldpathname As newpathname"
End Property

Public Property Get OldPathName() As String
OldPathName = "oldpathname"
End Property

Public Property Get NewPathName() As String
NewPathName = "newpathname"
End Property

Public Property Get RuleOpen() As String
RuleOpen = "Rule: Open pathname For mode [Access access] [lock] As [#]filenumber [Len=reclength]"
End Property

Public Property Get PathName() As String
PathName = "pathname"
End Property

Public Property Get RulePrint() As String
RulePrint = "Rule: Print #filenumber, [outputlist]"
End Property

Public Property Get ExpSubscript() As String
ExpSubscript = "Expected: subscript"
End Property

Public Property Get RuleSeek() As String
RuleSeek = "Rule: Seek [#]filenumber, position"
End Property

Public Property Get PositionName() As String
PositionName = "position"
End Property

Public Property Get RuleUnlock() As String
RuleUnlock = "Rule: Unlock [#]filenumber[, recordrange]"
End Property

Public Property Get RuleWhile() As String
RuleWhile = "Rule: While condition"
End Property

Public Property Get ExpWend() As String
ExpWend = "Expected: Wend or End While"
End Property

Public Property Get RuleAttribute() As String
RuleAttribute = "Rule: Attribute [varname.]identifier = expression"
End Property

Public Property Get ExpVarId() As String
ExpVarId = "Expected: varname or identifier"
End Property

Public Property Get ExpEq() As String
ExpEq = "Expected: " & Equal
End Property

Public Property Get ExpExpr() As String
ExpExpr = "Expected: expression"
End Property

Public Property Get ContinueNonDo() As String
ContinueNonDo = "Continue Do not within Do ... Loop"
End Property

Public Property Get ContinueNonFor() As String
ContinueNonFor = "Continue For not within For ... Next"
End Property

Public Property Get ContinueNonWhile() As String
ContinueNonWhile = "Continue While not within While ... Wend"
End Property

Public Property Get ExitNonDo() As String
ExitNonDo = "Exit Do not within Do ... Loop"
End Property

Public Property Get ExitNonFor() As String
ExitNonFor = "Exit For not within For ... Next"
End Property

Public Property Get ExitNonWhile() As String
ExitNonWhile = "Exit While not within While ... Wend"
End Property

Public Property Get ExitNonSub() As String
ExitNonSub = "Exit Sub not allowed in Function or Property"
End Property

Public Property Get ExitNonFunc() As String
ExitNonFunc = "Exit Function not allowed in Sub or Property"
End Property

Public Property Get ExitNonProp() As String
ExitNonProp = "Exit Property not allowed in Function or Sub"
End Property

Public Property Get ExitNonSelect() As String
ExitNonSelect = "Exit Select not within Select ... End Select"
End Property

Public Property Get ZeroOne() As String
ZeroOne = "0 or 1"
End Property

Public Property Get Comma() As String
Comma = ","
End Property

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

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

Public Property Get ExpEOS() As String
ExpEOS = "Expected: End of statement"
End Property

Public Property Get InvLinNum() As String
InvLinNum = "Invalid line number"
End Property

Public Property Get ExpGoToSub() As String
ExpGoToSub = "Expected: GoTo or GoSub"
End Property

Public Property Get ExpGoToResume() As String
ExpGoToResume = "Expected: GoTo or Resume"
End Property

Public Property Get ExpBaseEtc() As String
ExpBaseEtc = "Base or Explicit or Compare"
End Property

Public Property Get NeedImpl() As String
NeedImpl = "Class need to implement '{0}' for interface '{1}'"
End Property

Public Property Get UndefUDT() As String
UndefUDT = "User-defined type not defined"
End Property

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

Public Property Get ArrayDimed() As String
ArrayDimed = "Array already dimensioned"
End Property

Public Property Get DefBeforeDim() As String
DefBeforeDim = "Deftype statements must precede declarations"
End Property
End Class


Public Class NameBank
Option Explicit

Private Ids_ As KeyedList
Private Keywords_ As KeyedList
Private Operators_ As KeyedList
Private Contextuals_ As KeyedList
Private DollarNames_ As KeyedList

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

Set Ids_ = New KeyedList
Set Ids_.T = NewValidator(TypeName(""))
Ids_.CompareMode = vbTextCompare
Ids_.Add v.String, v.String

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

Rem Keyword order must follow the Enum's one.
Values = Array(v.Any, v.As, v.Attribute, v.Boolean, v.ByRef, v.Byte, v.ByVal, v.Call, v.Case, v.CDecl, _
v.Circle, v.Class, v.Close, v.Const, v.Continue, v.Currency, v.Date, v.Declare, v.Default, _
v.DefBool, v.DefByte, v.DefCur, v.DefDate, v.DefDbl, v.DefDec, v.DefInt, v.DefLng, v.DefLngLng, _
v.DefLngPtr, v.DefObj, v.DefSng, v.DefStr, v.DefVar, v.Dim, v.Do, v.Double, v.Each, v.Else, v.ElseIf, _
v.Empty, v.End, v.EndIf, v.Enum, v.Erase, v.Event, v.Exit, v.False, v.For, v.Friend, v.Function, _
v.Get, v.Global, v.GoSub, v.GoTo, v.If, v.Implements, v.In, v.Input, v.Integer, v.Iterator, v.Let, _
v.Local, v.Long, v.LongLong, v.LongPtr, v.Loop, v.LSet, v.Me, v.Module, v.Next, v.Nothing, v.Null, _
v.On, v.Open, v.Option, v.Optional, v.ParamArray, v.Preserve, v.Print, v.Private, v.PSet, v.Public, _
v.Put, v.RaiseEvent, v.ReDim, v.[Rem], v.Resume, v.Return, v.RSet, v.Scale, v.Seek, v.Select, v.Set, _
v.Single, v.Static, v.Stop, v.String, v.Sub, v.Then, v.To, v.True, v.Type, v.Unlock, v.Until, _
v.Variant, v.Void, v.Wend, v.While, v.With, v.WithEvents, v.Write)

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

Keywords_.ReadOnly = True

Set Contextuals_ = New KeyedList
Set Contextuals_.T = NewValidator(TypeName(""))
Contextuals_.CompareMode = vbTextCompare

Values = Array(v.Access, v.Alias, v.Append, v.Base, v.Binary, v.Compare, v.Decimal, v.Error, v.Explicit, _
v.Len, v.Lib, v.Line, v.Lock, v.Name, v.Object, v.Output, v.Property, v.PtrSafe, v.Random, v.Read, _
v.Reset, v.Shared, v.Spc, v.Step, v.Tab, v.Text, v.Width)

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

Contextuals_.ReadOnly = True

Set Operators_ = New KeyedList
Set Operators_.T = NewValidator(TypeName(""))
Operators_.CompareMode = vbTextCompare
Rem Operator order must follow the Enum's one.
Values = Array(v.AddressOf, v.AndAlso, v.ByVal, v.Is, v.IsNot, v.Like, v.New, v.Not, v.OrElse, v.To, _
v.TypeOf, "~+", "~-", "<", "<=", "=", ">=", ">", "<>", ":=", "~.", "~!", ".", "!", _
v.And, v.Eqv, v.Imp, v.Mod, v.Or, v.Xor, "+", "-", "*", "/", "\", "^", "<<", ">>", ">>>", "&", _
v.And & "=", v.Eqv & "=", v.Imp & "=", v.Mod & "=", v.Or & "=", v.Xor & "=", "+=", "-=", "*=", _
"/=", "\=", "^=", "<<=", ">>=", ">>>=", "&=", "")

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

Operators_.ReadOnly = True

Set DollarNames_ = New KeyedList
Set DollarNames_.T = NewValidator(TypeName(""))
DollarNames_.CompareMode = vbTextCompare

Values = Array(v.Error, v.String, v.Date, v.Hex, v.Oct, v.Str, v.CurDir, v.Command, v.Environ, _
v.Chr, v.ChrB, v.ChrW, v.Format, v.LCase, v.Left, v.LeftB, v.LTrim, v.Mid, v.MidB, v.Right, _
v.RightB, v.RTrim, v.Space, v.Trim, v.UCase, v.Time, v.Bin)

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

DollarNames_.ReadOnly = True
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 Property Get DollarNames() As KeyedList
Set DollarNames = DollarNames_
End Property

Public Default Function Item(ByVal Token As Token) As String
Select Case Token.Kind
Case tkOperator
Item = Operators_(Token.Code)

Case tkKeyword
If Token.Code <= Keywords_.Count Then
Item = Keywords_(Token.Code)
Else
Item = Contextuals_(Token.Code - Keywords_.Count)
End If

Case Else
If Token.Code <= Keywords_.Count + Contextuals_.Count Then
Item = Contextuals_(Token.Code - Keywords_.Count)
Else
Item = Ids_(Token.Code - Keywords_.Count - Contextuals_.Count)
End If
End Select
End Function
End Class


Public Class NameConstruct
Option Explicit
Implements IStmt

Public OldPathName As IExpression
Public NewPathName As IExpression

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


Public Class OnComputedConstruct
Option Explicit
Implements IStmt

Private Targets_ As KeyedList

Public Value As IExpression
Public IsGoTo As Boolean

Private Sub Class_Initialize()
Set Targets_ = New KeyedList
Set Targets_.T = New StmtValidator
End Sub

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

Public Property Get Targets() As KeyedList
Set Targets = Targets_
End Property
End Class


Public Class OnErrorConstruct
Option Explicit
Implements IStmt

Public Statement As IStmt

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


Public Class OpenConstruct
Option Explicit
Implements IStmt

Public Enum FileModes
fmRandom
fmAppend
fmBinary
fmInput
fmOutput
End Enum

Public Enum FileAccesses
faNone
faRead
faWrite
faReadWrite
End Enum

Public Enum FileLocks
flShared
flRead
flWrite
flReadWrite
End Enum

Public PathName As IExpression
Public FileMode As FileModes
Public FileAccess As FileAccesses
Public FileLock As FileLocks
Public FileNumber As IExpression
Public Length As IExpression

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, opIdentity, 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 IsArray As Boolean
Public DataType As DataType
Public Id As Identifier
Public Init As IExpression
End Class


Public Class Parser
Option Explicit

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
IsDefault As Boolean
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 State_ As NarrowContext

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

Public Property Set SourceFile(ByVal Source As SourceFile)
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 SourceFile() As SourceFile
Set SourceFile = Source_
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(ReturnInlineComment:=ForPrint)
Else
Set Token = LookAhead_
Set LookAhead_ = Nothing
End If

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

If Downgrade_ And Not LastToken_ Is Nothing Then _
If LastToken_.Kind = tkIdentifier And _
LastToken_.Code < NameBank.Contextuals.Count + NameBank.Keywords.Count Then _
EnsureIdExists LastToken_

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

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

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
If Downgrade_ And _
Token.Code <= NameBank.Contextuals.Count + NameBank.Keywords.Count Then _
EnsureIdExists Token

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

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, m.NoSygil

Token.Kind = tkKeyword
Name = NameBank(Token)
Token.Code = NameBank.Contextuals.IndexOf(Name) + NameBank.Keywords.Count
If Revoke Then State_ = ncNone
End If
End If

Select Case Token.Kind
Case tkWhiteSpace, tkInlineComment
Rem OK

Case Else
Set LastToken_ = Token
End Select
Loop Until 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 Source's properties like Consts, Enums, etc.
Public Sub Parse(ByVal Source As SourceFile)
Dim Name As String
Dim Token As Token
Dim Mark As Token
Dim Entity As Entity
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.Access = acPublic
Set Token = NextToken

ElseIf Token.IsKeyword(kwPrivate) Then
Entity.Access = 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.Access = acLocal Then
Fail Token, m.RuleEntityHeader, m.PublicEtc

Else
Fail Token, m.RuleEntityHeader, m.ClassModule
End If

Set Mark = Token

If Entity.Access = acLocal Then Entity.Access = acPublic
Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, m.RuleEntityHeader, m.IdName

Set Entity.Id = NewId(Token)
SymTable.Add Entity
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, m.RuleEndEntity, v.End
End If

Set Token = NextToken
If Not Token.IsKeyword(IIf(Entity.IsClass, kwClass, kwModule)) Then Fail Token, m.ExpEnd & NameBank(Mark)

Name = NameBank(Entity.Id.Name)
If Source_.Entities.Exists(Name) Then Fail Entity.Id.Name, m.AmbiguousName & Name
Source_.Entities.AddKeyValue Name, Entity
MustEatLineBreak
Loop
End Sub

Private Function ParseDeclarationArea(ByVal Entity As Entity) As AccessToken
Dim HadBase As Boolean
Dim KeepToken As Boolean
Dim HadDefault As Boolean
Dim HasDefault As Boolean
Dim HadCompare As Integer
Dim Text As String
Dim Token As Token
Dim TkDef As Token
Dim Panel As ControlPanel
Dim Access As Accessibility

Set Panel = New ControlPanel
Set Panel.Entity = Entity

Do
If Not KeepToken Then Set Token = SkipLineBreaks
KeepToken = False

If Token.Kind = tkKeyword Then
Select Case Token.Code
Case kwAttribute
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
Set Token = ParseAttributes(Entity.Attributes, Token)
KeepToken = True

Case kwOption
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail Token, m.RuleOption, m.ExpBaseEtc

Select Case Token.Code
Case cxBase
If Panel.HadArray Then Fail Token, m.ArrayDimed
If HadBase Then Fail Token, m.DuplOption
HadBase = True

Set Token = NextToken

If Token.Kind <> tkIntegerNumber Or (Token.Text <> "+0" And Token.Text <> "+1") Then
Fail Token, m.RuleOptionBase, m.ZeroOne
End If

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

Case cxCompare
If HadCompare Then Fail Token, m.DuplOption
HadCompare = True

Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail Token, m.RuleOptionCompare, m.BinOrTxt

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

Case cxText
Entity.OptionCompare = vbTextCompare

Case Else
Fail Token, m.RuleOptionCompare, m.BinOrTxt
End Select

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

Case Else
Fail Token, m.RuleOption, v.Option
End Select

Case kwDefBool
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbBoolean, Entity, Panel

Case kwDefByte
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbByte, Entity, Panel

Case kwDefInt
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbInteger, Entity, Panel

Case kwDefLng
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbLong, Entity, Panel

Case kwDefLngLng
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbLongLong, Entity, Panel

Case kwDefLngPtr
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbLongPtr, Entity, Panel

Case kwDefCur
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbCurrency, Entity, Panel

Case kwDefDec
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbDecimal, Entity, Panel

Case kwDefSng
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbSingle, Entity, Panel

Case kwDefDbl
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbDouble, Entity, Panel

Case kwDefDate
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbDate, Entity, Panel

Case kwDefStr
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbString, Entity, Panel

Case kwDefObj
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbObject, Entity, Panel

Case kwDefVar
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDef vbVariant, Entity, Panel

Case kwPublic, kwGlobal
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
Access = acPublic

Case kwPrivate
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
Access = acPrivate

Case kwConst
If Access = acLocal Then Access = acPrivate
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseConsts Access, Panel, Entity.Consts
Access = acLocal

Case kwEnum
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseEnum Access, Panel
Access = acLocal

Case kwDeclare
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseDeclare Access, Panel
Access = acLocal

Case kwEvent
If Not Entity.IsClass Then Fail Token, m.ValidInClass
If Access = acLocal Then Access = acPublic
If Access <> acPublic Then Fail Token, m.EventIsPublic
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseEvent Panel
Access = acLocal

Case kwImplements
If Not Entity.IsClass Then Fail Token, m.ValidInClass
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
ParseImplements Entity

Case kwWithEvents
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
If Access = acLocal Then Access = acPublic
ParseDim Access, Panel, Entity.Vars, Token:=Token
Access = acLocal

Case kwDefault
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
Set TkDef = Token
HadDefault = HadDefault + 1

Case kwDim
If Access = acLocal Then Access = acPublic
ParseDim Access, Panel, Entity.Vars
Access = acLocal

Case kwType
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
If Access = acLocal Then Access = acPublic
ParseType Access, Panel
Access = acLocal

Case kwFriend
If Access <> acLocal Then Fail Token, m.RuleIdHeader, m.IdName
If Not Entity.IsClass Then Fail Token, m.ValidInClass
If HadDefault Then Fail TkDef, m.InvUseOf & v.Default
Access = acFriend
Exit Do

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

Case Else
Fail Token, m.ExpOptEtc
End Select

ElseIf Token.IsId(cxProperty) Then
Token.Kind = tkKeyword
Exit Do

ElseIf IsProperId(Token, CanHaveSuffix:=True) Then
If HadDefault And Access <> acPublic Then Fail TkDef, m.InvUseOf & v.Default
If HadDefault > 1 Then Fail TkDef, m.DuplDefault
ParseDim Access, Panel, Entity.Vars, Token:=Token, HasDefault:=HadDefault
Access = acLocal

Else
Fail Token, m.ExpOptEtc
End If
Loop

With ParseDeclarationArea
.Access = Access
Set .Token = Token
.IsDefault = HadDefault
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 Token As Token
Dim Proc As SubConstruct
Dim Panel As ControlPanel
Dim Access As Accessibility
Dim Func As FunctionConstruct
Dim Prop As PropertyConstruct

IsDefault = AccessToken.IsDefault
HadDefault = IsDefault

Access = AccessToken.Access
Set Token = AccessToken.Token

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

Case kwPrivate
If Access <> acLocal Then Fail Token, m.RuleFriendId, m.IdName
Access = acPrivate

Case kwFriend
If Access <> acLocal Then Fail Token, m.RuleFriendId, m.IdName
Access = acFriend

Case kwDefault
If IsDefault Or HadDefault Then Fail Token, m.DuplDefault
HadDefault = True
IsDefault = True

Case kwIterator
If IsIterator Or HadIterator Then Fail Token, m.DuplIterator
HadIterator = True
IsIterator = True

Case kwStatic
If IsStatic Then Fail Token, m.DuplStatic
IsStatic = True

Case kwSub
Set Panel = New ControlPanel
Set Panel.Entity = Entity
Panel.BodyType = ewSub

Set Proc = ParseSub(Access, Panel, IsDefault)
Panel.Validate Me, Entity
Proc.IsStatic = IsStatic
GoSub Cleanup

Case kwFunction
Set Panel = New ControlPanel
Set Panel.Entity = Entity
Panel.BodyType = ewFunction

Set Func = ParseFunction(Access, Panel, IsDefault)
Panel.Validate Me, Entity
Func.IsStatic = IsStatic
Func.IsIterator = IsIterator
If Func.IsDefault And Func.IsIterator Then Fail Token, m.NoDefaultIt
GoSub Cleanup

Case cxProperty
Set Panel = New ControlPanel
Set Panel.Entity = Entity
Panel.BodyType = ewProperty

Set Prop = ParseProperty(Access, Panel, IsDefault)
Panel.Validate Me, Entity
Prop.IsStatic = IsStatic
GoSub Cleanup

Case Else
Exit Do
End Select

Set Token = SkipLineBreaks
If Token.IsId(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, ByVal Panel As ControlPanel)
Dim First As String
Dim Last As String
Dim Token As Token
Dim Mark As Token

Do
Set Token = SkipLineBreaks
If Panel.HadDim Then Fail Token, m.DefBeforeDim
Set Mark = Token

If Token.Kind <> tkIdentifier Then Fail Token, m.RuleDefType, m.Letter1
If Token.Suffix <> vbNullChar Then Fail Token, m.NoSygil

First = NameBank(Token)
Set Token = NextToken

If Token.IsOperator(opSubt) Then
Set Token = NextToken
If Token.Kind <> tkIdentifier Or Token.Suffix <> vbNullChar Then Fail Token, m.RuleDefType, m.Letter2

Last = NameBank(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, m.DuplDefType
End If

On Error GoTo 0

If IsBreak(Token) Then Exit Do
If Token.Kind <> tkListSeparator Then Fail Token, m.RuleDefType, m.Comma
Loop
End Sub

Private Function ParseConsts( _
ByVal Access As Accessibility, _
ByVal Panel As ControlPanel, _
ByVal Body As KeyedList, _
Optional ByVal InsideProc As Boolean _
) As Token
Dim Name As String
Dim Token As Token
Dim Cnt As ConstConstruct
Dim Xp As New Expressionist

Do
Rem Get Const's name
Set Token = SkipLineBreaks
EnsureIdExists Token
If Not IsProperId(Token) Then Fail Token, m.RuleConst, m.IdName

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, m.IdHasSygil

Rem Get Const's data type name
Set Token = NextToken
If Not IsConstDataType(Token) Then Fail Token, m.RuleConst, m.DataType

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

If Token.IsOperator(opMul) Then
If Cnt.DataType.Id.Name <> v.String Then Fail Token, m.FixedLength

Set Cnt.DataType.FixedLength = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Cnt.DataType.FixedLength Is Nothing Then Fail Token, m.InvExpr
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, m.RuleConst, m.Equal

Rem Get Const's value
Set Cnt.Value = Xp.GetExpression(Me)
If Cnt.Value Is Nothing Then Fail Token, m.InvExpr

Rem Ensure it's not a duplicated Const
If Not InsideProc Then CheckDupl Panel.Entity, Cnt.Id.Name
Name = NameBank(Cnt.Id.Name)
If Body.Exists(Name) Then Fail Cnt.Id.Name, m.AmbiguousName & Name

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

Rem Save it
Body.AddKeyValue NameBank(Cnt.Id.Name), Cnt
Panel.AddConst Me, Cnt
SymTable.Add Cnt, Panel

Rem Move on
Set Token = Xp.LastToken

If IsBreak(Token) Then Exit Do
If InsideProc Then If Token.IsKeyword(kwElse) Then Exit Do

If Token.Kind <> tkListSeparator Then Fail Token, m.RuleConst, m.CommaOrEOS
Loop

Set ParseConsts = Token
End Function

Private Sub ParseEnum(ByVal Access As Accessibility, ByVal Panel As ControlPanel)
Dim Token As Token
Dim Enm As EnumConstruct
Dim Emd As EnumerandConstruct
Dim Xp As New Expressionist

Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token) Then Fail Token, m.RuleEnum, m.IdName
If Token.Suffix <> vbNullChar Then Fail Token, m.EnumSygil

Set Enm = New EnumConstruct
If Access = acLocal Then Access = acPublic
Enm.Access = Access
Set Enm.Id = NewId(Token)
SymTable.Add Enm, Panel

Set Token = NextToken
If Not IsBreak(Token) Then Fail Token, m.ExpEOS

Do
Set Token = SkipLineBreaks
If Token.IsKeyword(kwEnd) Then Exit Do
If Not Token.IsId(Token.Code) Then Fail Token, m.RuleAssign, m.IdName
If Token.Suffix <> vbNullChar Then Fail Token, m.EnumerandSygil

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
If Emd.Value Is Nothing Then Fail Token, m.InvExpr
End If

If Enm.Enumerands.Exists(NameBank(Emd.Id.Name)) Then Fail Emd.Id.Name, m.AmbiguousName & NameBank(Emd.Id.Name)

Enm.Enumerands.AddKeyValue NameBank(Emd.Id.Name), Emd
SymTable.Add Emd, Panel, Enm
Loop While IsBreak(Token)

If Not Token.IsKeyword(kwEnd) Then Fail Token, m.RuleEndEnum, v.End

Set Token = NextToken
If Not Token.IsKeyword(kwEnum) Then Fail Token, m.RuleEndEnum, v.Enum
MustEatLineBreak

If Enm.Enumerands.Count = 0 Then Fail Enm, m.EmptyEnum
CheckDupl Panel.Entity, Enm.Id.Name

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

Private Sub ParseDeclare(ByVal Access As Accessibility, ByVal Panel As ControlPanel)
Dim Token As Token
Dim Tkn As Token
Dim Dcl As DeclareConstruct

Set Dcl = New DeclareConstruct
If Access = acLocal Then Access = acPublic
Dcl.Access = Access

Rem Is it PtrSafe?
Set Token = NextToken

If Token.IsKeyword(cxPtrSafe) 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, m.RuleDeclareHeader, m.SubFunc
End If

Rem Get its name.
Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, m.RuleDeclareHeader, m.IdName

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, m.RuleDeclareHeader, v.Lib

Rem Get Lib's name
Set Token = NextToken
If Token.Kind <> tkString Then Fail Token, m.RuleDeclareHeader, m.LibString
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, m.RuleDeclareHeader, m.AliasString

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

Rem Get its parameters.
If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Panel, 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, m.ExpEOS
If Token.Suffix <> vbNullChar Then Fail Token, m.IdHasSygil

Rem Get data type name
Set Token = NextToken

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

If Token.IsOperator(opDot) Then
Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, m.RuleDeclareHeader, m.DataType

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

Case tkKeyword
If Not IsBuiltinDataType(Token) Then Fail Token, m.RuleDeclareHeader, m.DataType
Set Dcl.DataType = NewDataType(Token)
Set Token = NextToken

Case Else
Fail Token, m.RuleDeclareHeader, m.DataType
End Select

Rem Maybe it returns an array?
If Token.Kind = tkLeftParenthesis Then
Set Token = NextToken
If Token.Kind <> tkRightParenthesis Then Fail Token, m.ParensMismatch
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 = Panel.Entity.DefTypes(NameBank(Dcl.Id.Name))
Else
Set Dcl.DataType = FromChar(Dcl.Id.Name.Suffix)
End If
End If

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

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

Panel.Entity.Declares.AddKeyValue NameBank(Dcl.Id.Name), Dcl
SymTable.Add Dcl, Panel
End Sub

Private Function ParseParms( _
ByVal Panel As ControlPanel, _
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

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, m.TooManyParms

If Token.IsKeyword(kwOptional) Then
If LastParm.IsParamArray Then Fail Token, m.OptParamArray
If SignatureKind = skEvent Or SignatureKind = skTuple Then Fail Token, m.NoOptional
CurrParm.IsOptional = True
Set Token = NextToken

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

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

ElseIf Token.IsKeyword(kwByRef) Then
If SignatureKind = skTuple Then Fail Token, m.NoByref
CurrParm.IsByVal = False 'Technically this is not needed
Set Token = NextToken
End If
End If

EnsureIdExists Token
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, m.RuleParm, m.IdName
Set CurrParm.Id = NewId(Token)

Set Token = NextToken

If Token.Kind = tkLeftParenthesis Then
Set Token = NextToken
If Token.Kind <> tkRightParenthesis Then Fail Token, m.RuleParm, m.CloseParens
CurrParm.IsArray = True
Set Token = NextToken
End If

If CurrParm.IsParamArray And Not CurrParm.IsArray Then Fail CurrParm.Id, m.ParamIsArray

If Token.IsKeyword(kwAs) Then
If CurrParm.Id.Name.Suffix <> vbNullChar Then Fail Token, m.IdHasSygil
Set Token = NextToken

If SignatureKind = skDeclare Then
If Not IsDataType(Token) Then Fail Token, m.RuleParm, m.DataType
Else
If Not IsProperDataType(Token) Then Fail Token, m.RuleParm, m.DataType
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, m.AsPrjId, m.IdName

Set CurrParm.DataType.Id.Name = Token

If CurrParm.IsParamArray And ( _
CurrParm.DataType.Id.Project Is Nothing Imp _
CurrParm.DataType.Id.Name.Code <> kwVariant) Then _
Fail Token, m.ParamIsArray

Set Token = NextToken
End If

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

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

If Token.IsOperator(opEq) Then
If Not CurrParm.IsOptional Then Fail Token, m.NonOptional
If CurrParm.IsParamArray Then Fail Token, m.NoParamDefault
Set CurrParm.Init = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If CurrParm.Init Is Nothing Then Fail Token, m.InvExpr
End If

If Not CurrParm.IsOptional And (LastParm.IsOptional Or LastParm.IsParamArray) Then
If SignatureKind <> skPropertyLet And SignatureKind <> skPropertySet Then _
Fail CurrParm.Id, m.RuleParm, v.Optional

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, m.ArgReqProp

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

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

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

If Parms.Exists(Name) Then
If SignatureKind <> skDeclare Then Fail CurrParm.Id, m.Duplicated
Count = 1

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

Parms.AddKeyValue Name, CurrParm
If SignatureKind <> skDeclare And SignatureKind <> skEvent Then Panel.AddVar Me, CurrParm
Return
End Function

Private Sub ParseEvent(ByVal Panel As ControlPanel)
Dim Token As Token
Dim Evt As EventConstruct

Set Token = SkipLineBreaks
EnsureIdExists Token
If Not IsProperId(Token) Then Fail Token, m.RuleEvent, m.IdName

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

Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Panel, skEvent, Evt.Parameters)

If Not IsBreak(Token) Then Fail Token, m.ExpEOS
CheckDupl Panel.Entity, Evt.Id.Name
Panel.Entity.Events.AddKeyValue NameBank(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
EnsureIdExists Token
If Token.Kind <> tkIdentifier Then Fail Token, m.RuleImplements, m.PrjOrId
If Token.Suffix <> vbNullChar Then Fail Token, m.NoSygil

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, m.RuleImplements, m.IdName
If Token.Suffix <> vbNullChar Then Fail Token, m.NoSygil

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

If Not IsBreak(Token) Then Fail Token, m.ExpEOS
Set Token = Impls.Id.Name
Name = NameBank(Token)
If Entity.Impls.Exists(Name) Then Fail Token, m.AmbiguousName & Name
Entity.Impls.Add Impls, Name
End Sub

Private Function ParseSub( _
ByVal Access As Accessibility, _
ByVal Panel As ControlPanel, _
ByVal HadDefault As Boolean _
) As SubConstruct
Dim Name As String
Dim Token As Token
Dim Proc As SubConstruct

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

Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token) Then Fail Token, m.RuleSubHeader, m.IdName

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

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

ElseIf Not IsBreak(Token) Then
Fail Token, m.ExpEOS
End If

Set Token = ParseAttributes(Proc.Attributes)
Set Panel.Method = Nothing
SymTable.Add Proc, Panel
Set Panel.Method = Proc

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

Set Token = ParseBody(Panel, Proc.Body, LookAhead:=Token)
If Not Token.IsKeyword(kwSub) Then Fail Token, m.RuleEndSub, v.Sub
MustEatLineBreak

Set ParseSub = Proc
End Function

Private Function ParseFunction( _
ByVal Access As Accessibility, _
ByVal Panel As ControlPanel, _
ByVal HadDefault As Boolean _
) As FunctionConstruct
Dim Name As String
Dim Token As Token
Dim Parm As Parameter
Dim Func As FunctionConstruct

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

Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, m.RuleFuncHeader, m.IdName

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

Set Token = NextToken

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

ElseIf Not IsBreak(Token) Then
Fail Token, m.ExpEOS
End If

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

If Token.IsKeyword(kwAs) Then
Set Token = NextToken
If Not IsProperDataType(Token) Then Fail Token, m.AsPrjId, m.PrjOrId
Set Func.DataType = NewDataType(Token)

Set Token = NextToken

If Token.IsOperator(opDot) Then
Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, m.AsPrjId, m.IdName

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 = Panel.Entity.DefTypes(Name)
End If

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

If Not IsBreak(Token) Then MustEatLineBreak
Set Token = ParseAttributes(Func.Attributes)
Set Panel.Method = Nothing

If Func.Id.Name.Suffix = "$" Then
If NameBank.DollarNames.Exists(Name) Then
Name = Name & "$"
Func.Id.Name.Suffix = vbNullChar
If Not NameBank.Ids.Exists(Name) Then NameBank.Ids.Add Name, Name
Func.Id.Name.Code = NameBank.Ids.IndexOf(Name) + NameBank.Contextuals.Count + NameBank.Keywords.Count
End If
End If

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

SymTable.Add Func, Panel
Set Panel.Method = Func
Set Token = ParseBody(Panel, Func.Body, LookAhead:=Token)
If Not Token.IsKeyword(kwFunction) Then Fail Token, m.RuleEndFunc, v.Function
MustEatLineBreak

Set ParseFunction = Func
End Function

Private Function ParseProperty( _
ByVal Access As Accessibility, _
ByVal Panel As ControlPanel, _
ByVal HadDefault As Boolean _
) 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
Prop.IsDefault = HadDefault

Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail Token, m.ExpGLSet

Select Case Token.Code
Case kwGet
Kind = VbGet

Case kwLet
Kind = VbLet

Case kwSet
Kind = VbSet

Case Else
Fail Token, m.RulePropHeader, m.GLSet
End Select

Prop.Kind = Kind
Set Token = NextToken
EnsureIdExists Token
Set PropToken = Token
Name = NameBank(Token)

If Token.Suffix = "$" And NameBank.DollarNames.Exists(Name) Then
Name = Name & "$"
Token.Suffix = vbNullChar
End If

If Not IsProperId(Token, CanHaveSuffix:=Kind = VbGet) Then _
Fail Token, m.RulePropHeader, m.IdName

CheckDupl Panel.Entity, Token, JumpProp:=True

If Panel.Entity.Properties.Exists(Name) Then
Set Slot = Panel.Entity.Properties(Name)

If Token.Suffix <> vbNullChar And Slot.Id.Name.Suffix <> Token.Suffix Then
Slot.Id.Name.Suffix = Token.Suffix
IsNew = True
Set Slot = New PropertySlot
Set Slot.Id = NewId(Token)
End If
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( _
Panel, _
Switch(Kind = VbGet, skPropertyGet, Kind = VbLet, skPropertyLet, True, skPropertySet), _
Prop.Parameters _
)

ElseIf Not IsBreak(Token) Then
Fail Token, m.ExpEOS
End If

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

If Token.IsKeyword(kwAs) Then
Set Token = NextToken
If Not IsProperDataType(Token) Then Fail Token, m.AsPrjId, m.PrjOrId
Set Prop.DataType = NewDataType(Token)

Set Token = NextToken

If Token.IsOperator(opDot) Then
Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, m.AsPrjId, m.IdName

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

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

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

If Token.Kind = tkLeftParenthesis Then
Set Token = NextToken
If Token.Kind <> tkRightParenthesis Then Fail Token, m.ParensMismatch
Prop.DataType.IsArray = True
End If

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

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

If Right$(Name, 1) = "$" Then
If Not NameBank.Ids.Exists(Name) Then NameBank.Ids.Add Name, Name
Slot.Id.Name.Code = NameBank.Ids.IndexOf(Name) + NameBank.Contextuals.Count + NameBank.Keywords.Count
End If

If IsNew Then
Panel.Entity.Properties.Add Slot, Name

ElseIf Slot.Exists(Kind) Then
Fail PropToken, m.AmbiguousName & Name
End If

Slot.Add Kind, Prop
Set Prop.Id = Slot.Id
Set Panel.Method = Prop
SymTable.Add Prop, Panel, Slot

Set Token = ParseAttributes(Prop.Attributes)
Set Token = ParseBody(Panel, Prop.Body, LookAhead:=Token)
If Not Token.IsId(cxProperty) Then Fail Token, m.RuleEndProp
MustEatLineBreak

If Kind <> VbGet Then
Set Parm = Prop.Parameters(Prop.Parameters.Count)
If Parm.IsOptional Then Fail Slot.Id.Name, m.PropMismatch
If Parm.IsParamArray Then Fail Slot.Id.Name, m.PropMismatch
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, m.PropMismatch

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

If Kind = VbGet Then
If Prop.DataType.IsArray <> RightParms(RightParms.Count).DataType.IsArray Then _
Fail Slot.Id.Name, m.PropMismatch

If Prop.DataType.Id.Name.Code <> RightParms(RightParms.Count).DataType.Id.Name.Code Then _
Fail Slot.Id.Name, m.PropMismatch
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, m.PropMismatch

For Idx = 1 To LeftParms.Count
If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail Slot.Id.Name, m.PropMismatch
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, m.PropMismatch

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

Set ParseProperty = Prop
End Function

Private Function ParseAttributes(ByVal Attrs As KeyedList, Optional ByVal Token As Token) As Token
Dim Attr As AttributeConstruct
Dim Xp As New Expressionist

Do
If Token Is Nothing Then Set Token = NextToken
If Not Token.IsKeyword(kwAttribute) Then Exit Do

Set Attr = New AttributeConstruct
Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token) Then Fail Token, m.RuleAttribute, m.ExpVarId
Set Attr.Id = NewId(Token)

Set Token = NextToken

If Token.IsOperator(opDot) Then
Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, m.ExpVarId, m.IdName

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

If Not Token.IsOperator(opEq) Then Fail Token, m.ExpVarId, m.ExpEq
Set Attr.Value = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Attr.Value Is Nothing Then Fail Token, m.ExpVarId, m.ExpExpr

If Not IsBreak(Token) Then Exit Do
Set Token = Nothing
Loop

Set ParseAttributes = Token
End Function

Private Sub ParseDim( _
ByVal Access As Accessibility, _
ByVal Panel As ControlPanel, _
ByVal Vars As KeyedList, _
Optional ByVal InsideProc As Boolean, _
Optional ByVal IsStatic As Boolean, _
Optional ByVal Token As Token, _
Optional HasDefault As Boolean _
)
Dim Name As String
Dim WasArray As Boolean
Dim Var As Variable
Dim Expr As IExpression
Dim Subs As SubscriptPair
Dim Xp As Expressionist
Dim Bin As BinaryExpression

Panel.HadDim = True
If InsideProc Then If Access = acPublic Or Access = acPrivate Then Fail Token, m.NotInsideMethod
If Token Is Nothing Then Set Token = NextToken

Set Xp = New Expressionist
Xp.CanHaveTo = True
Xp.FullMode = True

Do
Set Var = New Variable
Var.Access = Access
Var.IsStatic = IsStatic
Var.IsDefault = HasDefault
HasDefault = False

If Token.IsKeyword(kwWithEvents) Then
If Not Panel.Entity.IsClass Then Fail Token, m.ValidInClass
If InsideProc Then Fail Token, m.NotInsideMethod

Var.HasWithEvents = True
Set Token = NextToken
End If

EnsureIdExists Token
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, m.RuleDim, m.IdName
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(Panel.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(Panel.Entity)
Set Subs.UpperBound = Expr
End If

Case Else
Debug.Assert False
Fail Token, m.InvExpr
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, m.ParensMismatch

Panel.HadArray = True
WasArray = True
Set Token = NextToken
End If

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

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

If Not IsProperDataType(Token) Then Fail Token, m.RuleDim, m.DataType
Set Var.DataType = NewDataType(Token)

If Var.HasNew And Var.DataType.Id.Name.Kind = tkKeyword Then _
Fail Token, m.InvUseOf & NameBank.Operators(opNew - NameBank.Keywords.Count)

Set Token = NextToken

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

If Not IsProperDataType(Token) Then Fail Token, m.RuleDim, m.IdName
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 = Panel.Entity.DefTypes(NameBank(Var.Id.Name))
End If

If Token.IsOperator(opMul) Then
Set Var.DataType.FixedLength = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Var.DataType.FixedLength Is Nothing Then Fail Token, m.InvExpr
End If

Var.DataType.IsArray = WasArray
If Var.HasNew And Var.DataType.IsArray Then _
Fail Token, m.InvUseOf & NameBank.Operators(opNew - NameBank.Keywords.Count)

If Token.IsOperator(opEq) Then
Set Var.Init = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Var.Init Is Nothing Then Fail Token, m.InvExpr
End If

Name = NameBank(Var.Id.Name)
If Not InsideProc Then CheckDupl Panel.Entity, Var.Id.Name
If Vars.Exists(Name) Then Fail Token, m.AmbiguousName & Name
Vars.Add Var, Name
Panel.AddVar Me, Var
SymTable.Add Var, Panel

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

Private Sub ParseType(ByVal Access As Accessibility, ByVal Panel As ControlPanel)
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
EnsureIdExists Token
If Not IsProperId(Token) Then Fail Token, m.RuleType, m.IdName

Set Typ.Id = NewId(Token)
SymTable.Add Typ, Panel

MustEatLineBreak
Set Token = Nothing 'Force ParseDim to get next token

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

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, m.RuleTypeMember, v.As

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

Ent.Vars.Clear
Name = NameBank(Var.Id.Name)
If Typ.Members.Exists(Name) Then Fail Var.Id.Name, m.AmbiguousName & Name

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

Set Token = NextToken
If Not Token.IsKeyword(kwType) Then Fail Token, m.RuleEndType, v.Type

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

Private Function ParseBody( _
ByVal Panel As ControlPanel, _
ByVal Body As KeyedList, _
Optional ByVal IsSingleLine As Boolean, _
Optional ByVal LookAhead As Token _
) As Token
Dim Token As Token
Dim Stmt As IStmt
Dim LStmt As LetConstruct
Dim SStmt As SetConstruct
Dim Xp As Expressionist
Dim Label As LabelConstruct
Dim LinNum As LineNumberConstruct

Set Xp = New Expressionist

Do
If LookAhead Is Nothing Then
Set Token = SkipLineBreaks
Else
Set Token = LookAhead
Set LookAhead = Nothing
If IsBreak(Token) Then Set Token = SkipLineBreaks
End If

If Not IsSingleLine Then
Rem Do we have a line number?
If Token.Kind = tkIntegerNumber And Left$(Token.Text, 1) <> "-" Then
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token
Body.Add LinNum
Panel.AddLine LinNum
Set Token = NextToken
End If

Rem Do we have a label?
If Token.Kind = tkIdentifier Or Token.Kind = tkEscapedIdentifier Or Token.Kind = tkCrazyIdentifier Then
Set LookAhead = NextToken

If LookAhead.Kind = tkSoftLineBreak Then
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Body.Add Label
Panel.AddLabel Label
Set LookAhead = Nothing
Set Token = NextToken
End If
End If
End If

Select Case Token.Kind
Case tkKeyword
Select Case Token.Code
Case kwCall
Set Stmt = Xp.GetStmt(Me)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail Token, m.ExpEqArg
If Stmt.Kind <> snCall Then Stop 'TODO: Remove Stop
Body.Add Stmt

Case kwClose
Set LookAhead = ParseClose(Body)

Case kwConst
Set LookAhead = ParseConsts(acLocal, Panel, Body, InsideProc:=True)

Case kwContinue
ParseContinue Panel, Body

Case kwDim
ParseDim acLocal, Panel, Body, InsideProc:=True

Case kwDo
ParseDo Panel, Body

Case kwEnd
Rem Is it a closing End?
Set LookAhead = NextToken

Select Case LookAhead.Kind
Case tkKeyword
Select Case LookAhead.Code
Case kwFunction, kwIf, kwSelect, kwSub, kwWhile, kwWith
Exit Do
End Select

Case tkIdentifier
If LookAhead.Code = cxProperty Then Exit Do
End Select

Body.Add New EndConstruct

Case kwErase
Set LookAhead = ParseErase(Body)

Case kwExit
ParseExit Panel, Body

Case kwFor
Set LookAhead = ParseFor(Panel, Body)

Case kwGet
ParseGet Body

Case kwGoSub
ParseGoSub Panel, Body

Case kwGoTo
ParseGoTo Panel, Body

Case kwIf
Set LookAhead = ParseIf(Panel, Body)

Case kwInput
Set LookAhead = ParseInput(Body)

Case kwLet
Set Stmt = Xp.GetStmt(Me)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail Token, m.ExpEqArg
If Stmt.Kind <> snLet Then Stop 'TODO: Remove Stop
Body.Add Stmt

Case kwLSet
Set LookAhead = ParseLSet(Body)

Case kwOn
Set LookAhead = ParseOn(Panel, Body)

Case kwOpen
Set LookAhead = ParseOpen(Body)

Case kwPrint
Set LookAhead = ParsePrint(Body)

Case kwPut
ParsePut Body

Case kwRaiseEvent
Set LookAhead = ParseRaiseEvent(Body)

Case kwReDim
ParseReDim Panel, Body

Case kwResume
Set LookAhead = ParseResume(Panel, Body)

Case kwReturn
Body.Add New ReturnConstruct

Case kwRSet
Set LookAhead = ParseRSet(Body)

Case kwSeek
Set LookAhead = ParseSeek(Body)

Case kwSelect
ParseSelect Panel, Body

Case kwSet
Set Stmt = Xp.GetStmt(Me)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail Token, m.ExpEqArg
If Stmt.Kind <> snLet Then Stop 'TODO: Remove Stop

Set LStmt = Stmt
Set SStmt = New SetConstruct
Set SStmt.Name = LStmt.Name
Set SStmt.Value = LStmt.Value
Set Stmt = SStmt
Body.Add Stmt

Case kwStatic
ParseDim acLocal, Panel, Body, InsideProc:=True, IsStatic:=True

Case kwStop
Body.Add New StopConstruct

Case kwUnlock
Set LookAhead = ParseUnlock(Body)

Case kwWhile
ParseWhile Panel, Body

Case cxWidth
Set LookAhead = ParseWidth(Body)

Case kwWith
ParseWith Panel, Body

Case kwWrite
Set LookAhead = ParseWrite(Body)

Case kwCase, kwElse, kwElseIf, kwLoop, kwNext, kwWend
Set LookAhead = Token
Exit Do

Case cxName
Set LookAhead = ParseName(Body)

Case Else
Rem It should not happen
Debug.Assert False
End Select

Case tkIdentifier
Select Case Token.Code
Case cxLock
Set LookAhead = ParseLock(Body)

Case cxReset
Body.Add New ResetConstruct

Case cxWidth
Set LookAhead = ParseWidth(Body)

Case Else
Up:
Set Stmt = Xp.GetStmt(Me, Token, LookAhead)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail Token, m.ExpEqArg
Body.Add Stmt
End Select

Case tkEscapedIdentifier
GoTo Up

Case tkDirective
Rem TODO: Fix it
Do
Set Token = NextToken
Loop Until IsBreak(Token)

Case tkOperator
Select Case Token.Code
Case opWithBang, opWithDot
GoTo Up

Case Else
Fail Token, m.ExpStmt
End Select

Case tkHardLineBreak
Rem Nothing to do

Case Else
Debug.Assert False
Fail Token, m.ExpStmt
End Select
Loop Until IsSingleLine

If LookAhead Is Nothing Then
Set ParseBody = NextToken
Else
Set ParseBody = LookAhead
End If
End Function

Private Function IsStatement(ByVal Token As Token) As Boolean
Select Case Token.Kind
Case tkOperator
IsStatement = Token.Code = opWithBang Or Token.Code = opWithDot

Case tkIdentifier, tkEscapedIdentifier, tkCrazyIdentifier, tkKeyword
IsStatement = True
End Select
End Function

Private Function ParseClose(ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Expr As IExpression
Dim Xp As Expressionist
Dim Stmt As CloseConstruct

Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt = New CloseConstruct

Do
Set Expr = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Expr Is Nothing Then Exit Do

Rem TODO: Check expression's type?
Stmt.FileNumbers.Add Expr
Loop While Token.Kind = tkListSeparator

Body.Add Stmt
Set ParseClose = Token
End Function

Private Sub ParseContinue(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As ContinueConstruct

Set Stmt = New ContinueConstruct
Set Token = NextToken

If Token.Kind <> tkKeyword Then Fail Token, m.ExpDoEtc

Select Case Token.Code
Case kwDo
If Panel.DoCount = 0 Then Fail Token, m.ContinueNonDo
Stmt.What = cwDo

Case kwFor
If Panel.ForCount = 0 Then Fail Token, m.ContinueNonFor
Stmt.What = cwFor

Case kwWhile
If Panel.WhileCount = 0 Then Fail Token, m.ContinueNonWhile
Stmt.What = cwWhile
End Select

Body.Add Stmt
End Sub

Private Sub ParseDo(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Mark As Token
Dim Stmt As DoConstruct
Dim Xp As Expressionist

Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt = New DoConstruct
Set Token = NextToken
Set Mark = Token

If Token.IsKeyword(kwWhile) Then
Stmt.DoType = dtDoWhileLoop
Set Stmt.Condition = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.Condition Is Nothing Then Fail Mark, m.InvExpr

ElseIf Token.IsKeyword(kwUntil) Then
Stmt.DoType = dtDoUntilLoop
Set Stmt.Condition = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.Condition Is Nothing Then Fail Mark, m.InvExpr
End If

If Not IsBreak(Token) Then Fail Token, m.ExpEOS
Panel.DoCount = Panel.DoCount + 1
Set Token = ParseBody(Panel, Stmt.Body)
Panel.DoCount = Panel.DoCount - 1
If Not Token.IsKeyword(kwLoop) Then Fail Token, m.ExpLoop

Set Token = NextToken
Set Mark = Token

If Stmt.DoType = dtNone Then
If Token.IsKeyword(kwWhile) Then
Stmt.DoType = dtDoLoopWhile
Set Stmt.Condition = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.Condition Is Nothing Then Fail Mark, m.InvExpr

ElseIf Token.IsKeyword(kwUntil) Then
Stmt.DoType = dtDoUntilLoop
Set Stmt.Condition = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.Condition Is Nothing Then Fail Mark, m.InvExpr
End If
End If

If Not IsBreak(Token) Then Fail Token, m.ExpEOS
Body.Add Stmt
End Sub

Private Function ParseErase(ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Sym As Symbol
Dim Stmt As EraseConstruct

Set Stmt = New EraseConstruct

Do
Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, m.RuleErase, m.IdName

Set Sym = New Symbol
Set Sym.Value = Token
Stmt.Vars.Add Sym

Set Token = NextToken
Loop While Token.Kind = tkListSeparator

Body.Add Stmt
Set ParseErase = Token
End Function

Private Sub ParseExit(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As ExitConstruct

Set Stmt = New ExitConstruct
Set Token = NextToken

If Token.IsKeyword(kwDo) Then
If Panel.DoCount = 0 Then Fail Token, m.ExitNonDo
Stmt.What = ewDo

ElseIf Token.IsKeyword(kwFor) Then
If Panel.ForCount = 0 Then Fail Token, m.ExitNonFor
Stmt.What = ewFor

ElseIf Token.IsKeyword(kwWhile) Then
If Panel.WhileCount = 0 Then Fail Token, m.ExitNonWhile
Stmt.What = ewWhile

ElseIf Token.IsKeyword(kwSub) Then
If Panel.BodyType <> ewSub Then Fail Token, m.ExitNonSub
Stmt.What = ewSub

ElseIf Token.IsKeyword(kwFunction) Then
If Panel.BodyType <> ewFunction Then Fail Token, m.ExitNonFunc
Stmt.What = ewFunction

ElseIf Token.IsId(cxProperty) Then
If Panel.BodyType <> ewProperty Then Fail Token, m.ExitNonProp
Stmt.What = ewProperty

ElseIf Token.IsKeyword(kwSelect) Then
If Panel.SelectCount = 0 Then Fail Token, m.ExitNonSelect
Stmt.What = ewSelect

Else
Fail Token, m.ExpDoForEtc
End If

Body.Add Stmt
End Sub

Private Function ParseFor(ByVal Panel As ControlPanel, ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Mark As Token
Dim Lit As Literal
Dim Expr As IExpression
Dim Stmt As ForConstruct
Dim Xp As Expressionist
Dim Bin As BinaryExpression

Set Xp = New Expressionist
Xp.FullMode = True
Xp.CanHaveTo = True
Set Token = NextToken

If Token.IsKeyword(kwEach) Then
ParseForEach Panel, Body
Exit Function
End If

Set Stmt = New ForConstruct
EnsureIdExists Token
If Not IsProperId(Token) Then Fail Token, m.RuleFor, m.IdName

Set Stmt.Counter = New Symbol
Set Stmt.Counter.Value = Token

Set Token = NextToken
If Not Token.IsOperator(opEq) Then Fail Token, m.RuleFor, m.Equal
Set Mark = Token

Set Expr = Xp.GetExpression(Me)
Set Token = Xp.LastToken

If Expr Is Nothing Then Fail Mark, m.InvExpr
If Expr.Kind <> ekBinaryExpr Then Fail Mark, m.InvExpr
Set Bin = Expr
If Not Bin.Operator.Value.Code = opTo Then Fail Token, m.RuleFor, v.To

Set Stmt.StartValue = Bin.LHS
Set Stmt.EndValue = Bin.RHS

If Token.IsId(cxStep) Then
Set Mark = Token
Xp.CanHaveTo = False
Set Stmt.Increment = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.Increment Is Nothing Then Fail Mark, m.RuleFor, m.Increment
Else
Set Lit = New Literal
Set Lit.Value = New Token
Lit.Value.Kind = tkIntegerNumber
Lit.Value.Text = "1"
Lit.Value.Code = vbInteger
Set Stmt.Increment = Lit
End If

If Not IsBreak(Token) Then Fail Token, m.ExpEOS
Panel.ForCount = Panel.ForCount + 1
Set Token = ParseBody(Panel, Stmt.Body)
Panel.ForCount = Panel.ForCount - 1
If Not Token.IsKeyword(kwNext) Then Fail Token, m.ExpNext

Set Token = NextToken

If IsProperId(Token) And Token.Code = Stmt.Counter.Value.Code Then
Rem Next token should be a line-break or a comma.
Set Token = NextToken

If Token.Kind = tkListSeparator Then
Set Token = New Token
Token.Kind = tkKeyword
Token.Code = kwNext

ElseIf IsBreak(Token) Then
Rem OK

Else
Fail Token, m.ExpEOS
End If

ElseIf IsBreak(Token) Then
Rem OK

Else
Fail Token, m.ExpEOS
End If

Body.Add Stmt
Set ParseFor = Token
End Function

Private Sub ParseForEach(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As ForEachConstruct
Dim Xp As Expressionist

Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt = New ForEachConstruct
Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token) Then Fail Token, m.RuleForEach, m.VariableName

Set Stmt.Element = New Symbol
Set Stmt.Element.Value = Token

Set Token = NextToken
If Not Token.IsKeyword(kwIn) Then Fail Token, m.RuleForEach, v.In

Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, m.RuleForEach, m.GroupName
Set Stmt.Group = Xp.GetStmt(Me, Token)
If Stmt.Group Is Nothing Then Fail Token, m.RuleForEach, m.GroupName

Set Token = Xp.LastToken
If Not IsBreak(Token) Then Fail Token, m.ExpEOS

Panel.ForCount = Panel.ForCount + 1
Set Token = ParseBody(Panel, Stmt.Body)
Panel.ForCount = Panel.ForCount - 1
If Not Token.IsKeyword(kwNext) Then Fail Token, m.ExpNext

MustEatLineBreak
Body.Add Stmt
End Sub

Private Sub ParseGet(ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As GetConstruct
Dim Xp As Expressionist

Set Stmt = New GetConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken

If Stmt.FileNumber Is Nothing Then Fail Token, m.RuleGet, m.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Token, m.RuleGet, m.Comma

Set Stmt.RecNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken
Rem RecNumber can be nothing
If Token.Kind <> tkListSeparator Then Fail Token, m.RuleGet, m.Comma

Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, m.RuleGet, m.VariableName

Set Stmt.Var = New Symbol
Set Stmt.Var.Value = Token
Body.Add Stmt
End Sub

Private Sub ParseGoSub(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As GoSubConstruct
Dim Label As LabelConstruct
Dim LinNum As LineNumberConstruct

Set Stmt = New GoSubConstruct
Set Token = NextToken

Select Case Token.Kind
Case tkIdentifier, tkEscapedIdentifier, tkCrazyIdentifier
EnsureIdExists Token
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Set Stmt.Target = Label
Panel.AddTarget Label

Case tkIntegerNumber
If Left$(Token.Text, 1) = "-" Then Fail Token, m.ExpTarget
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token

Set Stmt.Target = LinNum
Panel.AddTarget LinNum

Case Else
Fail Token, m.ExpTarget
End Select

Body.Add Stmt
End Sub

Private Sub ParseGoTo(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As GoToConstruct
Dim Label As LabelConstruct
Dim LinNum As LineNumberConstruct

Set Stmt = New GoToConstruct
Set Token = NextToken

Select Case Token.Kind
Case tkIdentifier, tkEscapedIdentifier, tkCrazyIdentifier
EnsureIdExists Token
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Set Stmt.Target = Label
Panel.AddTarget Label

Case tkIntegerNumber
If Left$(Token.Text, 1) = "-" Then Fail Token, m.ExpTarget
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token

Set Stmt.Target = LinNum
Panel.AddTarget LinNum

Case Else
Fail Token, m.ExpTarget
End Select

Body.Add Stmt
End Sub

Private Function ParseIf(ByVal Panel As ControlPanel, ByVal Body As KeyedList) As Token
Dim Arm As IfArm
Dim Token As Token
Dim Stmt As IfConstruct
Dim Xp As Expressionist

Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt = New IfConstruct

Set Arm = New IfArm
Rem If <condition> ?
Set Token = NextToken
Set Arm.Condition = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken
If Arm.Condition Is Nothing Then Fail Token, m.InvExpr

Rem If <condition> Then ?
If Not Token.IsKeyword(kwThen) Then Fail Token, m.RuleIf, v.Then

Stmt.Arms.Add Arm
Set Token = NextToken

If Token.Kind = tkSoftLineBreak Then
Rem If <condition> Then :
Do
Set Token = NextToken
If IsHardBreak(Token) Then Exit Do
Up:
If Not IsStatement(Token) Then Fail Token, m.ExpStmt

Rem If <condition> Then : <statement>
Set Token = ParseBody(Panel, Arm.Body, IsSingleLine:=True, LookAhead:=Token)
Loop While Token.Kind = tkSoftLineBreak

If Token.IsKeyword(kwElse) Then
Rem If <condition> Then : <statement> Else
Set Token = NextToken

Do
If Token.Kind = tkSoftLineBreak Then Set Token = NextToken
If Not IsStatement(Token) Then Fail Token, m.ExpStmt

Set Token = ParseBody(Panel, Stmt.ElseBody, IsSingleLine:=True, LookAhead:=Token)
Loop While Token.Kind = tkSoftLineBreak
End If

If Not IsHardBreak(Token) Then Fail Token, m.ExpEOS

ElseIf IsHardBreak(Token) Then
Set Token = ParseBody(Panel, Arm.Body)
If Token.Kind <> tkKeyword Then Fail Token, m.ExpElseEtc

Do
Select Case Token.Code
Case kwElseIf
Set Arm = New IfArm
Set Arm.Condition = Xp.GetExpression(Me)
If Arm.Condition Is Nothing Then Fail Token, m.InvExpr

Set Token = Xp.LastToken
If Not Token.IsKeyword(kwThen) Then Fail Token, m.RuleIf, v.Then

Set Token = ParseBody(Panel, Arm.Body)
Stmt.Arms.Add Arm

Case kwElse
Set Token = NextToken
If Not IsHardBreak(Token) Then Fail Token, m.ExpEOS

Set Token = ParseBody(Panel, Stmt.ElseBody)

If Token.IsKeyword(kwIf) Then
Set Token = NextToken
Exit Do
End If

Fail Token, m.ExpEnd & v.If

Case kwIf
Set Token = NextToken
Exit Do

Case Else
Fail Token, m.ExpElseEtc
End Select
Loop

ElseIf IsStatement(Token) Then
GoTo Up

Else
Fail Token, m.NonEndIf
End If

Body.Add Stmt
Set ParseIf = Token
End Function

Private Function ParseInput(ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Sym As Symbol
Dim Xp As Expressionist
Dim Stmt As InputConstruct

Set Stmt = New InputConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.FileNumber Is Nothing Then Fail Token, m.RuleInput, m.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Token, m.RuleInput, m.Comma

Do
Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, m.RuleInput, m.VariableName

Set Sym = New Symbol
Set Sym.Value = NewId(Token)
Stmt.Vars.Add Sym

Set Token = NextToken
Loop While Token.Kind = tkListSeparator

Body.Add Stmt
Set ParseInput = Token
End Function

Private Function ParseLock(ByVal Body As KeyedList) As Token
Dim Stmt As LockConstruct
Dim Xp As Expressionist

Set Stmt = New LockConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RuleLock, m.HashFileNumber

If Xp.LastToken.Kind = tkListSeparator Then
Xp.CanHaveTo = True
Set Stmt.RecordRange = Xp.GetExpression(Me)
If Stmt.RecordRange Is Nothing Then Fail Xp.LastToken, m.RuleLock, m.RecordRange
End If

Body.Add Stmt
Set ParseLock = Xp.LastToken
End Function

Private Function ParseLSet(ByVal Body As KeyedList) As Token
Dim ISt As IStmt
Dim Asg As LetConstruct
Dim Xp As Expressionist
Dim Stmt As LSetConstruct

Set Xp = New Expressionist
Set Stmt = New LSetConstruct

Set ISt = Xp.GetStmt(Me)
If ISt.Kind <> snLet Then Stop 'TODO: Remove Stop

Set Asg = ISt
If Asg.Name.Kind <> ekSymbol Then Stop 'TODO: Remove Stop
If Asg.Operator.Value.Code <> opEq Then Fail Asg.Operator.Value, m.RuleLSet, m.Equal

Set Stmt.Name = Asg.Name
Set Stmt.Value = Asg.Value
Body.Add Stmt
End Function

Private Function ParseName(ByVal Body As KeyedList) As Token
Dim Xp As Expressionist
Dim Stmt As NameConstruct

Set Stmt = New NameConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.OldPathName = Xp.GetExpression(Me)
If Stmt.OldPathName Is Nothing Then Fail Xp.LastToken, m.RuleName, m.OldPathName
If Not Xp.LastToken.IsKeyword(kwAs) Then Fail Xp.LastToken, m.RuleName, v.As

Set Stmt.NewPathName = Xp.GetExpression(Me)
If Stmt.NewPathName Is Nothing Then Fail Xp.LastToken, m.RuleName, m.NewPathName

Body.Add Stmt
Set ParseName = Xp.LastToken
End Function

Private Function ParseOn(ByVal Panel As ControlPanel, ByVal Body As KeyedList) As Token
Dim Token As Token
Dim WentTo As GoToConstruct
Dim Label As LabelConstruct
Dim ResStmt As ResumeConstruct
Dim OnStmt As OnErrorConstruct
Dim Xp As New Expressionist
Dim Comp As OnComputedConstruct
Dim LinNum As LineNumberConstruct

Set Token = NextToken

If Token.IsKeyword(cxError) Then
Set OnStmt = New OnErrorConstruct
Set Token = NextToken
If Token.IsKeyword(kwLocal) Then Set Token = NextToken

If Token.IsKeyword(kwGoTo) Then
Set Token = NextToken

Select Case Token.Kind
Case tkIntegerNumber
If Left$(Token.Text, 1) = "-" Then Fail Token, m.ExpTarget
Set WentTo = New GoToConstruct
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token
Set WentTo.Target = LinNum
Set OnStmt.Statement = WentTo
Panel.AddTarget LinNum

Case tkIdentifier, tkEscapedIdentifier, tkCrazyIdentifier
EnsureIdExists Token
Set WentTo = New GoToConstruct
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Set WentTo.Target = Label
Set OnStmt.Statement = WentTo
Panel.AddTarget Label

Case Else
Fail Token, m.ExpTarget
End Select

ElseIf Token.IsKeyword(kwResume) Then
Set Token = NextToken
If Not Token.IsKeyword(kwNext) Then Fail Token, m.ExpNext

Set ResStmt = New ResumeConstruct
ResStmt.IsNext = True
Set OnStmt.Statement = ResStmt

Else
Fail Token, m.ExpGoToSub
End If

Set Token = NextToken
Body.Add OnStmt

Else
Set Comp = New OnComputedConstruct
Xp.FullMode = True
Set Comp.Value = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken
If Comp.Value Is Nothing Then Fail Token, m.InvExpr

If Token.IsKeyword(kwGoTo) Then
Comp.IsGoTo = True

ElseIf Token.IsKeyword(kwGoSub) Then
'Comp.IsGoTo = False

Else
Fail Token, m.ExpGoToSub
End If

Do
Set Token = NextToken

Select Case Token.Kind
Case tkIntegerNumber
If Left$(Token.Text, 1) = "-" Then Fail Token, m.ExpTarget
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token
Comp.Targets.Add LinNum
Panel.AddTarget LinNum

Case tkIdentifier
EnsureIdExists Token
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Comp.Targets.Add Label
Panel.AddTarget Label

Case Else
Fail Token, m.ExpTarget
End Select

Set Token = NextToken
Loop While Token.Kind = tkListSeparator

Body.Add Comp
End If

Set ParseOn = Token
End Function

Private Function ParseOpen(ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Stmt As OpenConstruct
Dim Xp As Expressionist

Set Stmt = New OpenConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.PathName = Xp.GetExpression(Me)
If Stmt.PathName Is Nothing Then Fail Xp.LastToken, m.RuleOpen, m.PathName
If Not Xp.LastToken.IsKeyword(kwFor) Then Fail Xp.LastToken, m.RuleOpen, v.For

Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail Token, m.ExpAppendEtc

Select Case Token.Code
Case cxAppend
Stmt.FileMode = fmAppend

Case cxBinary
Stmt.FileMode = fmBinary

Case kwInput
Stmt.FileMode = fmInput

Case cxOutput
Stmt.FileMode = fmOutput

Case cxRandom
Stmt.FileMode = fmRandom

Case Else
Fail Token, m.ExpAppendEtc
End Select

Set Token = NextToken

If Token.IsKeyword(cxAccess) Then
Set Token = NextToken

If Token.IsKeyword(cxRead) Then
Stmt.FileAccess = faRead
Set Token = NextToken
End If

If Token.IsKeyword(kwWrite) Then
If Stmt.FileAccess = faRead Then Stmt.FileAccess = faReadWrite Else Stmt.FileAccess = faWrite
Set Token = NextToken
End If

If Stmt.FileAccess = faNone Then Fail Token, m.ExpReadWrite
End If

If Token.IsKeyword(cxShared) Then
Stmt.FileLock = flShared
Set Token = NextToken

ElseIf Token.IsKeyword(cxRead) Then
Stmt.FileLock = flRead
Set Token = NextToken

If Token.IsKeyword(kwWrite) Then
Stmt.FileAccess = faReadWrite
Set Token = NextToken
End If

ElseIf Token.IsKeyword(kwWrite) Then
Stmt.FileAccess = faWrite
Set Token = NextToken
End If

If Not Token.IsKeyword(kwAs) Then Fail Token, m.RuleOpen, v.As
Set Stmt.FileNumber = Xp.GetExpression(Me)
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RuleOpen, m.HashFileNumber
Set Token = Xp.LastToken

If Token.IsKeyword(cxLen) Then
Set Token = NextToken
If Not Token.IsOperator(opEq) Then Fail Token, m.RuleOpen, m.Equal

Set Stmt.Length = Xp.GetExpression(Me)
Set Token = Xp.LastToken
End If

Body.Add Stmt
Set ParseOpen = Token
End Function

Private Function ParsePrint(ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Sym As Symbol
Dim Arg As PrintArg
Dim Expr As IExpression
Dim Xp As Expressionist
Dim Exec As CallConstruct
Dim Stmt As PrintConstruct

Set Stmt = New PrintConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.FileNumber Is Nothing Then Fail Token, m.RulePrint, m.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Token, m.RulePrint, m.Comma
Set Token = Nothing

Do
Set Expr = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken
If Expr Is Nothing Then Fail Xp.LastToken, m.RulePrint, m.VariableName

Set Arg = New PrintArg

If Expr.Kind = ekIndexer Then
Set Exec = Expr

If Exec.LHS.Kind = ekSymbol Then
Set Sym = Exec.LHS

If Sym.Value.IsId(cxSpc) Then
If Exec.Arguments.Count <> 1 Then Stop 'TODO: Remove Stop
Set Arg.Indent = New PrintIndent
Set Arg.Indent.Value = Exec.Arguments(1)
Set Expr = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken

ElseIf Sym.Value.IsId(cxTab) Then
If Exec.Arguments.Count > 1 Then Stop 'TODO: Remove Stop
Set Arg.Indent = New PrintIndent
Arg.Indent.IsTab = True
Set Arg.Indent.Value = Exec.Arguments(1)
Set Expr = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken
End If
End If

ElseIf Expr.Kind = ekSymbol Then
Set Sym = Expr

If Sym.Value.IsId(cxTab) Then
Set Arg.Indent = New PrintIndent
Arg.Indent.IsTab = True
Set Expr = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken
End If
End If

Set Arg.Value = Expr

If Token.Kind = tkPrintSeparator Then
Arg.HasSemicolon = True
Set Token = NextToken
End If

Stmt.Output.Add Arg
Loop Until IsEndOfContext(Token)

Body.Add Stmt
Set ParsePrint = Token
End Function

Private Sub ParsePut(ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As PutConstruct
Dim Xp As Expressionist

Set Stmt = New PutConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken

If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RulePut, m.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, m.RulePut, m.Comma

Set Stmt.RecNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken
Rem RecNumber can be nothing
If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, m.RulePut, m.Comma

Set Token = NextToken
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, m.RulePut, m.IdName

Set Stmt.Var = New Symbol
Set Stmt.Var.Value = Token
Body.Add Stmt
End Sub

Private Function ParseRaiseEvent(ByVal Body As KeyedList) As Token
Dim Token As Token
Dim ISt As IStmt
Dim Sym As Symbol
Dim Xp As Expressionist
Dim Exec As CallConstruct
Dim Stmt As RaiseEventConstruct

Set Stmt = New RaiseEventConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set ISt = Xp.GetStmt(Me)
Set Token = Xp.LastToken
If ISt.Kind <> snCall Then Stop 'TODO: Remove Stop

Set Exec = ISt
If Exec.LHS.Kind <> ekSymbol Then Stop 'TODO: Remove Stop

Set Sym = Exec.LHS
Set Stmt.Id = NewId(Sym.Value)
Set Stmt.Arguments = Exec.Arguments

Body.Add Stmt
Set ParseRaiseEvent = Token
End Function

Private Sub ParseReDim(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Var As Variable
Dim Stmt As ReDimConstruct

Set Stmt = New ReDimConstruct
Set Token = NextToken

If Token.IsKeyword(kwPreserve) Then
Stmt.HasPreserve = True
Set Token = NextToken
End If

ParseDim acLocal, Panel, Stmt.Vars, InsideProc:=True, Token:=Token

For Each Var In Stmt.Vars
If Var.HasNew Then Fail Var.Id.Name, m.InvUseOf & NameBank.Operators(opNew - NameBank.Keywords.Count)
If Not Var.Init Is Nothing Then Stop 'TODO: Remove Stop
If Var.Subscripts.Count = 0 Then Fail Var.Id.Name, m.ExpSubscript
Panel.AddVar Me, Var, IsReDim:=True
Next

Body.Add Stmt
End Sub

Private Function ParseResume(ByVal Panel As ControlPanel, ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Label As LabelConstruct
Dim Stmt As ResumeConstruct
Dim LinNum As LineNumberConstruct

Set Stmt = New ResumeConstruct
Set Token = NextToken

Select Case Token.Kind
Case tkIntegerNumber
If Left$(Token.Text, 1) = "-" Then Fail Token, m.InvLinNum
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token
Set Stmt.Target = LinNum
Set Token = NextToken
Panel.AddLine LinNum

Case tkIdentifier, tkEscapedIdentifier, tkCrazyIdentifier
EnsureIdExists Token
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Set Stmt.Target = Label
Set Token = NextToken
Panel.AddLabel Label

Case tkKeyword
If Token.Code <> kwNext Then Fail Token, m.ExpNext
Stmt.IsNext = True
Set Token = NextToken

Case Else
Set LinNum = New LineNumberConstruct
Set LinNum.Value = New Token
LinNum.Value.Kind = tkIntegerNumber
LinNum.Value.Text = "+0"
LinNum.Value.Code = vbInteger
Set Stmt.Target = LinNum
End Select

Body.Add Stmt
Set ParseResume = Token
End Function

Private Sub ParseSelect(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Expr As IExpression
Dim Xp As Expressionist
Dim Cs As CaseConstruct
Dim Stmt As SelectConstruct
Dim IsExpr As BinaryExpression

Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt = New SelectConstruct

Set Token = NextToken
If Not Token.IsKeyword(kwCase) Then Fail Token, m.RuleSelect, v.Case

Set Stmt.Value = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.Value Is Nothing Then Fail Token, m.InvExpr
If Not IsBreak(Token) Then Fail Token, m.ExpEOS
Panel.SelectCount = Panel.SelectCount + 1

Rem From now on we'll accept the "To" operator
Xp.CanHaveTo = True

Do
Rem We can have a "look-ahead" token Case from ParseBody below.
Rem After parsing the statement block it may have stumbled upon "Case Else", for instance.
If Not Token.IsKeyword(kwCase) Then Set Token = SkipLineBreaks

Rem We will have this situation if there's an empty Select Case like:
Rem Select Case Abc
Rem End Select
If Token.IsKeyword(kwEnd) Then
Set Token = NextToken
If Token.IsKeyword(kwSelect) Then Exit Do
Fail Token, m.ExpEnd & v.Select
End If

Debug.Assert Token.IsKeyword(kwCase)
Set Cs = New CaseConstruct

Do
Set Expr = Xp.GetExpression(Me)
Set Token = Xp.LastToken

If Expr Is Nothing Then
If Token.IsOperator(opIs) Then
Rem We have an "Is" expression
Set IsExpr = New BinaryExpression
Rem IsExpr.LHS will be Nothing

Set Token = NextToken
If Token.Kind <> tkOperator Then Fail Token, m.ExpCompOp

Set IsExpr.Operator = NewOperator(Token)
If IsExpr.Operator.IsUnary Then Fail Token, m.ExpCompOp

Set IsExpr.RHS = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If IsExpr.RHS Is Nothing Then Fail Token, m.InvExpr

Set Expr = IsExpr

ElseIf Token.IsKeyword(kwElse) Then
Rem We have a "Case Else".
Set Token = ParseBody(Panel, Stmt.CaseElse)
If Not Token.IsKeyword(kwSelect) Then Fail Token, m.ExpEnd & v.Select

Rem Cs must not be added after Loop
Set Cs = Nothing
Exit Do

Else
Debug.Assert False
Fail Token, m.ExpIsElse
End If
End If

Cs.Conditions.Add Expr

If IsBreak(Token) Then
Set Token = ParseBody(Panel, Cs.Body)
Exit Do
End If

If Token.Kind <> tkListSeparator Then Fail Token, m.CommaOrEOS
Loop

If Not Cs Is Nothing Then Stmt.Cases.Add Cs
Loop Until Token.IsKeyword(kwSelect)

Panel.SelectCount = Panel.SelectCount - 1
Body.Add Stmt
End Sub

Private Function ParseRSet(ByVal Body As KeyedList) As Token
Dim ISt As IStmt
Dim Asg As LetConstruct
Dim Xp As Expressionist
Dim Stmt As RSetConstruct

Set Xp = New Expressionist
Set Stmt = New RSetConstruct

Set ISt = Xp.GetStmt(Me)
If ISt.Kind <> snLet Then Stop 'TODO: Remove Stop

Set Asg = ISt
If Asg.Name.Kind <> ekSymbol Then Stop 'TODO: Remove Stop
If Asg.Operator.Value.Code <> opEq Then Fail Asg.Operator.Value, m.RuleRSet, m.Equal

Set Stmt.Name = Asg.Name
Set Stmt.Value = Asg.Value
Body.Add Stmt
End Function

Private Function ParseSeek(ByVal Body As KeyedList) As Token
Dim Xp As Expressionist
Dim Stmt As SeekConstruct

Set Stmt = New SeekConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RuleSeek, m.HashFileNumber
If Xp.LastToken.Kind <> tkListSeparator Then Fail Xp.LastToken, m.RuleSeek, m.Comma

Set Stmt.Position = Xp.GetExpression(Me)
If Stmt.Position Is Nothing Then Fail Xp.LastToken, m.PositionName

Body.Add Stmt
Set ParseSeek = Xp.LastToken
End Function

Private Function ParseUnlock(ByVal Body As KeyedList) As Token
Dim Stmt As UnlockConstruct
Dim Xp As Expressionist

Set Stmt = New UnlockConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RuleUnlock, m.HashFileNumber

If Xp.LastToken.Kind = tkListSeparator Then
Xp.CanHaveTo = True
Set Stmt.RecordRange = Xp.GetExpression(Me)
If Stmt.RecordRange Is Nothing Then Fail Xp.LastToken, m.RuleUnlock, m.RecordRange
End If

Body.Add Stmt
Set ParseUnlock = Xp.LastToken
End Function

Private Sub ParseWhile(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Xp As Expressionist
Dim Stmt As WhileConstruct

Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt = New WhileConstruct

Set Stmt.Condition = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.Condition Is Nothing Then Fail Token, m.InvExpr

If Not IsBreak(Token) Then Fail Token, m.ExpEOS
Panel.WhileCount = Panel.WhileCount + 1
Set Token = ParseBody(Panel, Stmt.Body)
Panel.WhileCount = Panel.WhileCount - 1

If Token.IsKeyword(kwWend) Then
Rem OK

ElseIf Token.IsKeyword(kwWhile) Then
Rem OK

Else
Fail Token, m.ExpWend
End If

MustEatLineBreak
Body.Add Stmt
End Sub

Private Function ParseWidth(ByVal Body As KeyedList) As Token
Dim Stmt As WidthConstruct
Dim Xp As Expressionist

Set Stmt = New WidthConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RuleWidth, m.HashFileNumber
If Xp.LastToken.Kind <> tkListSeparator Then Fail Xp.LastToken, m.RuleWidth, m.Comma

Xp.CanHaveTo = True
Set Stmt.Value = Xp.GetExpression(Me)
If Stmt.Value Is Nothing Then Fail Xp.LastToken, m.RuleWidth, m.WidthName

Body.Add Stmt
Set ParseWidth = Xp.LastToken
End Function

Private Sub ParseWith(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As WithConstruct
Dim Xp As Expressionist

Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt = New WithConstruct

Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token) Then Fail Token, m.RuleWith, m.ObjectName

Set Stmt.PinObject = Xp.GetStmt(Me, Token)
Set Token = Xp.LastToken
If Stmt.PinObject Is Nothing Then Fail Token, m.RuleWith, m.ObjectName


Set Token = ParseBody(Panel, Stmt.Body, LookAhead:=Token)
If Not Token.IsKeyword(kwWith) Then Fail Token, m.ExpEnd & v.With

Body.Add Stmt
End Sub

Private Function ParseWrite(ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Expr As IExpression
Dim Xp As Expressionist
Dim Stmt As WriteConstruct

Set Stmt = New WriteConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RuleWrite, m.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, m.RuleWrite, m.Comma

Do
Set Expr = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Expr Is Nothing Then Exit Do

Stmt.Output.Add Expr
Loop While Token.Kind = tkListSeparator

Body.Add Stmt
Set ParseWrite = Token
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 SynthLower(ByVal Entity As Entity) As IExpression
Dim Token As Token
Dim Lit As Literal

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

Set Lit = New Literal
Set Lit.Value = Token
Set SynthLower = Lit
End Function

Private Sub MustEatLineBreak()
Dim Token As Token

Set Token = NextToken
If IsBreak(Token) Then Exit Sub
Fail Token, m.ExpEOS
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 IsProperId(ByVal Token As Token, Optional ByVal CanHaveSuffix As Boolean) As Boolean
If Not CanHaveSuffix And Token.Suffix <> vbNullChar Then Fail Token, m.NoSygil
IsProperId = Token.Kind = tkIdentifier Or Token.Kind = tkEscapedIdentifier
End Function

Friend Function IsHardBreak(ByVal Token As Token) As Boolean
IsHardBreak = Token.Kind = tkHardLineBreak Or Token.Kind = tkComment
End Function

Friend Function IsBreak(ByVal Token As Token) As Boolean
Select Case Token.Kind
Case tkSoftLineBreak, tkHardLineBreak, tkComment, tkEndOfStream
IsBreak = True
End Select
End Function

Private Function IsProperDataType(ByVal Token As Token) As Boolean
If Token.Suffix <> vbNullChar Then Fail Token, m.NoSygil

Select Case Token.Kind
Case tkIdentifier, tkEscapedIdentifier
IsProperDataType = True

Case tkKeyword
IsProperDataType = IsBuiltinDataType(Token)
End Select
End Function

Private Function IsConstDataType(ByVal Token As Token) As Boolean
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
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
If Token.Suffix <> vbNullChar Then Fail Token, m.NoSygil

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

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

If Not Result Then Result = Token.IsId(cxStep)
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

Select Case Token.Kind
Case tkEscapedIdentifier, tkCrazyIdentifier
Got = "[" & NameBank(Token) & "]"

Case tkFileHandle, tkDirective
Got = "#" & NameBank(Token)

Case tkWhiteSpace
Got = """ """

Case tkComment, tkString, tkDateTime
Got = """" & Token.Text & """"

Case tkIntegerNumber, tkFloatNumber, tkSciNumber, tkBinaryNumber, tkOctalNumber, tkHexaNumber
If Left$(Token.Text, 1) = "-" Then
Got = Token.Text
Else
Got = Mid$(Token.Text, 2)
End If

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 = """" & NameBank(Token) & """"
End Select

If Token.Suffix <> vbNullChar Then Got = Got & Token.Suffix
If Token.Code <> 0 Then Text = NameBank(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
Rem It should not happen
Debug.Assert False
End Select

Set FromChar = NewDataType(Token)
End Function

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

Name = NameBank(Token)

With Entity
If .Consts.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Enums.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Declares.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Events.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Impls.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Vars.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Types.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Subs.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Functions.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If Not JumpProp Then If .Properties.Exists(Name) Then Fail Token, m.AmbiguousName & Name
End With
End Sub

Friend Sub EnsureIdExists(ByVal Token As Token)
Dim Name As String

With NameBank
Name = .Item(Token)
If Not .Ids.Exists(Name) Then .Ids.Add Name, Name
Token.Code = .Ids.IndexOf(Name) + .Contextuals.Count + .Keywords.Count
Token.Kind = tkIdentifier
End With
End Sub
End Class


Public Class PINQ
Option Explicit
Implements KeyedList

Private MyBase_ As KeyedList

Public Enum PINQOperators
[>]
[>=]
[=]
[<=]
[<]
[<>]
[Like]
[In]
[And]
[Or]
[Desc]
End Enum

Private Sub Class_Initialize()
Set MyBase_ = New KeyedList
End Sub

Private Sub KeyedList_Add(ByVal Item As Variant, Optional ByVal Key As Variant, Optional Position As Variant)
MyBase_.Add Item, Key, Position
End Sub

Private Sub KeyedList_AddKeyValue(ByVal Key As String, ByVal Item As Variant)
MyBase_.AddKeyValue Key, Item
End Sub

Private Sub KeyedList_AddKVPairs(ParamArray KeyValuePairs() As Variant)
Dim Idx As Long

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

Private Sub KeyedList_AddValues(ParamArray Values() As Variant)
Dim Idx As Long

For Idx = 0 To UBound(Values)
MyBase_.Add Values(Idx)
Next
End Sub

Private Property Let KeyedList_Base(ByVal RHS As Integer)
MyBase_.Base = RHS
End Property

Private Property Get KeyedList_Base() As Integer
KeyedList_Base = MyBase_.Base
End Property

Private Sub KeyedList_Clear()
MyBase_.Clear
End Sub

Private Property Let KeyedList_CompareMode(ByVal RHS As VbCompareMethod)
MyBase_.CompareMode = RHS
End Property

Private Property Get KeyedList_CompareMode() As VbCompareMethod
KeyedList_CompareMode = MyBase_.CompareMode
End Property

Private Property Get KeyedList_Count() As Long
KeyedList_Count = MyBase_.Count
End Property

Private Property Get KeyedList_Exists(ByVal Key As String) As Boolean
KeyedList_Exists = MyBase_.Exists(Key)
End Property

Private Property Get KeyedList_IndexOf(ByVal Key As String) As Long
KeyedList_IndexOf = MyBase_.IndexOf(Key)
End Property

Private Property Get KeyedList_Item(ByVal Index As Variant) As Variant
If IsObject(MyBase_(Index)) Then
Set KeyedList_Item = MyBase_(Index)
Else
KeyedList_Item = MyBase_(Index)
End If
End Property

Private Function KeyedList_NewEnum() As IUnknown
Set KeyedList_NewEnum = MyBase_.NewEnum
End Function

Private Property Let KeyedList_ReadOnly(ByVal RHS As Boolean)
MyBase_.ReadOnly = RHS
End Property

Private Property Get KeyedList_ReadOnly() As Boolean
KeyedList_ReadOnly = MyBase_.ReadOnly
End Property

Private Sub KeyedList_Remove(ByVal Index As Variant)
MyBase_.Remove Index
End Sub

Private Property Set KeyedList_T(ByVal RHS As IKLValidator)
Set MyBase_.T = RHS
End Property

Public Iterator Function NewEnum() As IUnknown
Set NewEnum = KeyedList_NewEnum
End Function

Public Property Get ToList() As KeyedList
Set ToList = MyBase_
End Property

Public Default Property Get Item(ByVal Name As String) As Field
Set Item = New Field
Item.Name = Name
End Property

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Property Get From(ByVal Value As KeyedList) As PINQ
Set MyBase_ = Value
Set From = Me
End Property

Public Property Get Where(ParamArray Conditions() As Variant) As PINQ
Const Msg1 = "Expected: Field name or expression"
Const Msg2 = "Expected: Comparison operator"

Dim Keep As Boolean
Dim IsFirst As Boolean
Dim Idx As Long
Dim Jdx As Long
Dim Udx As Long
Dim Obj As Object
Dim LHS As Variant
Dim RHS As Variant
Dim Prop As Variant
Dim Op As OperatorNumbers
Dim Connect As OperatorNumbers

If MyBase_.Count > 0 Then
IsFirst = True
Idx = -1
Udx = UBound(Conditions)
ReDim Keeps(1 To MyBase_.Count) As Boolean

Do
Idx = Idx + 1
If Idx > Udx Then Err.Raise 5, TypeName(Me), Msg1

Idx = Idx + 1
If Idx > Udx Then Err.Raise 5, TypeName(Me), Msg2

Idx = Idx + 1
If Idx > Udx Then Err.Raise 5, TypeName(Me), Msg1

Op = Conditions(Idx - 1)

For Each Obj In MyBase_
Keep = False

If TypeOf Conditions(Idx - 2) Is Field Then
LHS = CallByName(Obj, Conditions(Idx - 2), VbGet)
Else
LHS = UCase$(Conditions(Idx - 2))
End If

If TypeOf Conditions(Idx) Is Field Then
RHS = CallByName(Obj, Conditions(Idx), VbGet)
Else
RHS = Conditions(Idx)
End If

Select Case Op
Case [>=]
Keep = LHS >= RHS

Case [>]
Keep = LHS > RHS

Case [=]
Keep = LHS = RHS

Case [<]
Keep = LHS < RHS

Case [<=]
Keep = LHS <= RHS

Case [<>]
Keep = LHS <> RHS

Case [Like]
Keep = LHS Like RHS

Case [And]
Keep = LHS And RHS

Case [Or]
Keep = LHS Or RHS

Case [In]
For Each Prop In RHS
If Prop = LHS Then Keep = True: Exit For
Next

Case Else
Debug.Assert False
End Select

Jdx = Jdx + 1

If IsFirst Then
Keeps(Jdx) = Keep

ElseIf Connect = [And] Then
Keeps(Jdx) = Keeps(Jdx) And Keep

ElseIf Connect = [Or] Then
Keeps(Jdx) = Keeps(Jdx) Or Keep

Else
Err.Raise 5, "PINQ", "Invalid operator"
End If
Next

IsFirst = False
Jdx = 0
Idx = Idx + 1
If Idx > Udx Then Exit Do
Connect = Conditions(Idx)
Loop

For Idx = MyBase_.Count To 1 Step -1
If Not Keeps(Idx) Then MyBase_.Remove Idx
Next
End If

Set Where = Me
End Property

Public Property Get Contains(ParamArray Conditions() As Variant) As Boolean
Const Msg1 = "Expected: Field name or expression"
Const Msg2 = "Expected: Comparison operator"

Dim Keep As Boolean
Dim IsFirst As Boolean
Dim Idx As Long
Dim Jdx As Long
Dim Udx As Long
Dim Obj As Object
Dim Field As Variant
Dim Value As Variant
Dim Prop As Variant
Dim Op As OperatorNumbers
Dim Connect As OperatorNumbers

If MyBase_.Count = 0 Then Exit Property
IsFirst = True
Idx = -1
Udx = UBound(Conditions)
ReDim Keeps(1 To MyBase_.Count) As Boolean

Do
Idx = Idx + 1
If Idx > Udx Then Err.Raise 5, TypeName(Me), Msg1

Idx = Idx + 1
If Idx > Udx Then Err.Raise 5, TypeName(Me), Msg2

Idx = Idx + 1
If Idx > Udx Then Err.Raise 5, TypeName(Me), Msg1

For Each Obj In MyBase_
If TypeOf Conditions(Idx - 2) Is Field Then
Field = CallByName(Obj, Conditions(Idx - 2), VbGet)
Else
Field = UCase$(Conditions(Idx - 2))
End If

Op = Conditions(Idx - 1)

If TypeOf Conditions(Idx) Is Field Then
Value = CallByName(Obj, Conditions(Idx), VbGet)
Else
Value = Conditions(Idx)
End If

Select Case Op
Case [>=]
Keep = Field >= Value

Case [>]
Keep = Field > Value

Case [=]
Keep = Field = Value

Case [<]
Keep = Field < Value

Case [<=]
Keep = Field <= Value

Case [<>]
Keep = Field <> Value

Case [Like]
Keep = Field Like Value

Case [And]
Keep = Field And Value

Case [Or]
Keep = Field Or Value

Case [In]
For Each Prop In Value
If Field = Prop Then Keep = True: Exit For
Next

Case Else
Debug.Assert False
End Select

Jdx = Jdx + 1

If IsFirst Then
Keeps(Jdx) = Keep

ElseIf Connect = opAnd Then
Keeps(Jdx) = Keeps(Jdx) And Keep

ElseIf Connect = opOr Then
Keeps(Jdx) = Keeps(Jdx) Or Keep

Else
Err.Raise 5, "PINQ", "Invalid operator"
End If
Next

IsFirst = False
Jdx = 0
Idx = Idx + 1
If Idx > Udx Then Exit Do
Connect = Conditions(Idx)
Loop

Contains = True

For Idx = 1 To MyBase_.Count
If Keeps(Idx) Then Exit Property
Next

Contains = False
End Property

Public Property Get OrderBy(ParamArray Fields() As Variant) As PINQ
Dim IsDesc As Boolean
Dim Swap As Boolean
Dim Idx As Long
Dim Length As Long
Dim Udx As Long
Dim Jdx As Long
Dim Field As String
Dim LHS As Variant
Dim RHS As Variant

Udx = UBound(Fields)
Length = MyBase_.Count

Do
Swap = False

For Idx = 2 To Length
Jdx = 0

Do
IsDesc = False
Field = Fields(Jdx)

If Jdx < Udx Then
If Not IsObject(Fields(Jdx + 1)) And Not IsArray(Fields(Jdx + 1)) Then
If Fields(Jdx + 1) = [Desc] Then Jdx = Jdx + 1: IsDesc = True
End If
End If

LHS = CallByName(MyBase_(Idx - 1), Field, VbGet)
RHS = CallByName(MyBase_(Idx), Field, VbGet)
Swap = False

If LHS < RHS Then
Swap = IsDesc
If Not Swap Then Exit Do

ElseIf LHS > RHS Then
Swap = Not IsDesc
If Not Swap Then Exit Do
End If

Jdx = Jdx + 1
Loop Until Jdx >= Udx Or Swap

If Swap Then
MyBase_.Add MyBase_(Idx), Before:=Idx - 1
MyBase_.Remove Idx + 1
Exit For
End If
Next
Loop While Swap

Set OrderBy = Me
End Property

Public Property Get Count() As Long
Count = MyBase_.Count
End Property
End Class


Public Class PrintArg
Option Explicit

Public Indent As PrintIndent
Public Value As IExpression
Public HasSemicolon As Boolean
End Class


Public Class PrintConstruct
Option Explicit
Implements IStmt

Private Output_ As KeyedList

Public FileNumber As IExpression

Private Sub Class_Initialize()
Set Output_ = New KeyedList
Set Output_.T = NewValidator(TypeName(New PrintArg))
End Sub

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

Public Property Get Output() As KeyedList
Set Output = Output_
End Property
End Class


Public Class PrintIndent
Option Explicit

Public IsTab As Boolean
Public Value As IExpression
End Class


Public Class PropertyConstruct
Option Explicit
Implements IMethod

Private Kind_ As VbCallType
Private Id_ As Identifier
Private Parms_ As KeyedList
Private Body_ As KeyedList
Private Attributes_ As KeyedList

Public Access As Accessibility
Public IsStatic As Boolean
Public IsDefault As Boolean
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

Set Attributes_ = New KeyedList
Set Attributes_.T = NewValidator(TypeName(New AttributeConstruct))
End Sub

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

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

Public Property Get Attributes() As KeyedList
Set Attributes = Attributes_
End Property

Public Property Get Id() As Identifier
Set Id = Id_
End Property

Friend Property Set Id(ByVal Value As Identifier)
Set Id_ = Value
End Property

Public Property Get Kind() As VbCallType
Kind = Kind_
End Property

Friend Property Let Kind(ByVal Value As VbCallType)
Kind_ = Value
End Property

Private Property Get IMethod_Access() As Accessibility
IMethod_Access = Access
End Property

Private Property Get IMethod_DataType() As DataType
Set IMethod_DataType = DataType
End Property

Private Property Get IMethod_Id() As Identifier
Set IMethod_Id = Id_
End Property

Private Property Get IMethod_Kind() As VbCallType
IMethod_Kind = Kind_
End Property

Private Property Get IMethod_Parameters() As KeyedList
Set IMethod_Parameters = Parms_
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 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
Rem It should not happen
Debug.Assert False
End Select

Item.Kind = Kind
Set Item.Id = Id
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
Rem It should not happen
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
Rem It should not happen
Debug.Assert False
End Select
End Property
End Class


Public Class PutConstruct
Option Explicit
Implements IStmt

Public FileNumber As IExpression
Public RecNumber As IExpression
Public Var As Symbol

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


Public Class RaiseEventConstruct
Option Explicit
Implements IStmt

Private Arguments_ As KeyedList

Public Id As Identifier

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

Public Property Get Arguments() As KeyedList
Set Arguments = Arguments_
End Property

Friend Property Set Arguments(ByVal Value As KeyedList)
Set Arguments_ = Value
End Property
End Class


Public Class ReDimConstruct
Option Explicit
Implements IStmt

Private Vars_ As KeyedList

Public HasPreserve As Boolean

Private Sub Class_Initialize()
Set Vars_ = New KeyedList
Set Vars_.T = NewValidator(TypeName(New Variable))
End Sub

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

Public Property Get Vars() As KeyedList
Set Vars = Vars_
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

Public IsNext As Boolean
Public Target As 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 Reverter
Option Explicit
Implements IVisitor

Private It_ As IVisitor

Public Builder As ITextBuilder

Private Sub Class_Initialize()
Set It_ = Me
End Sub

Private Sub IVisitor_VisitAccess(ByVal Access As Accessibility)
Select Case Access
Case acPublic
Builder.Append "Public "

Case acPrivate
Builder.Append "Private "

Case acFriend
Builder.Append "Friend "
End Select
End Sub

Private Sub IVisitor_VisitAttributes(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Attrs As KeyedList)
Dim Attr As AttributeConstruct

For Each Attr In Attrs
Builder.Append "Attribute "
It_.VisitId Attr.Id
Builder.Append "="
It_.VisitExpression vnConst, Entity, NullMethod, Attr.Value
Builder.AppendLn
Next
End Sub

Private Sub IVisitor_VisitBody(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Body As KeyedList)
Dim Stmt As IStmt

For Each Stmt In Body
It_.VisitStmt Entity, Method, Stmt
Builder.AppendLn
Next
End Sub

Private Sub IVisitor_VisitCall(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As CallConstruct)
Dim Count As Integer
Dim Expr As IExpression

It_.VisitExpression vnCall, Entity, Method, Stmt.LHS

If Stmt.Arguments.Count > 0 Then
Builder.Append "("

For Each Expr In Stmt.Arguments
It_.VisitExpression vnArg, Entity, Method, Expr
Count = Count + 1
If Count <> Stmt.Arguments.Count Then Builder.Append ", "
Next

Builder.Append ")"
End If
End Sub

Private Sub IVisitor_VisitClose(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As CloseConstruct)
Dim Number As IExpression

Builder.Append "Close"

For Each Number In Stmt.FileNumbers
Builder.Append " "
It_.VisitExpression vnVar, Entity, Method, Number
Next
End Sub

Private Sub IVisitor_VisitConst(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Cnt As ConstConstruct)
If Cnt.Access = acLocal Then Builder.Deindent

It_.VisitAccess Cnt.Access
Builder.Append "Const "
It_.VisitId Cnt.Id

If Not Cnt.DataType Is Nothing Then
Builder.Append " As "
It_.VisitDataType Entity, NullMethod, Cnt.DataType
End If

If Not Cnt.Value Is Nothing Then
Builder.Append " = "
It_.VisitExpression vnConst, Entity, NullMethod, Cnt.Value
End If

If Cnt.Access = acLocal Then Builder.Indent
End Sub

Private Sub IVisitor_VisitContinue(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ContinueConstruct)
Builder.Append "Continue "

Select Case Stmt.What
Case cwDo
Builder.Append "Do "

Case cwFor
Builder.Append "For "

Case cwWhile
Builder.Append "While "
End Select
End Sub

Private Sub IVisitor_VisitDataType(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal DataType As DataType)
It_.VisitId DataType.Id

If Not DataType.FixedLength Is Nothing Then
Builder.Append " * "
It_.VisitExpression vnData, Entity, NullMethod, DataType.FixedLength
End If
End Sub

Private Sub IVisitor_VisitDebug(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As DebugConstruct)
End Sub

Private Sub IVisitor_VisitDeclare(ByVal Entity As Entity, ByVal Dcl As DeclareConstruct)
It_.VisitAccess Dcl.Access
Builder.Append "Declare "
'Builder.Append "SafePtr "
Builder.Append IIf(Dcl.IsSub, "Sub ", "Function ")
It_.VisitId Dcl.Id
If Dcl.IsCDecl Then Builder.Append " CDecl"
Builder.Append " Lib "
It_.VisitToken Dcl.LibName
Builder.Append " "

If Not Dcl.AliasName Is Nothing Then
Builder.Append "Alias "
It_.VisitToken Dcl.AliasName
End If

It_.VisitParams Entity, Nothing, Dcl.Parameters

If Not Dcl.IsSub Then
Builder.Append " As "
It_.VisitDataType Entity, Nothing, Dcl.DataType
End If
End Sub

Private Sub IVisitor_VisitDim(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Stmt As Variable)
If Stmt.Access = acLocal Then
Builder.Append "Dim "
Else
It_.VisitAccess Stmt.Access
End If

If Stmt.IsDefault Then Builder.Append "Default "
If Stmt.HasWithEvents Then Builder.Append "WithEvents "
It_.VisitId Stmt.Id
It_.VisitSubscripts Entity, NullMethod, Stmt.Subscripts
Builder.Append " As "
If Stmt.HasNew Then Builder.Append "New "
It_.VisitDataType Entity, NullMethod, Stmt.DataType

If Not Stmt.Init Is Nothing Then
Builder.Append " = "
It_.VisitExpression vnLet, Entity, NullMethod, Stmt.Init
End If
End Sub

Private Sub IVisitor_VisitDo(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As DoConstruct)
Builder.Append "Do"

Select Case Stmt.DoType
Case dtDoWhileLoop
Builder.Append " While "
It_.VisitExpression vnLet, Entity, Method, Stmt.Condition

Case dtDoUntilLoop
Builder.Append " Until "
It_.VisitExpression vnLet, Entity, Method, Stmt.Condition
End Select

Builder.AppendLn
Builder.Indent

It_.VisitBody Entity, Method, Stmt.Body

Builder.Deindent
Builder.Append "Loop"

Select Case Stmt.DoType
Case dtDoLoopWhile
Builder.Append " While "
It_.VisitExpression vnLet, Entity, Method, Stmt.Condition

Case dtDoLoopUntil
Builder.Append " Until "
It_.VisitExpression vnLet, Entity, Method, Stmt.Condition
End Select
End Sub

Private Sub IVisitor_VisitEnd(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As EndConstruct)
Builder.Append "End"
End Sub

Private Sub IVisitor_VisitEntity(ByVal Entity As Entity)
Dim Sep As Boolean
Dim Count As Integer
Dim Def As DefType
Dim Var As Variable
Dim Slt As PropertySlot
Dim Prc As SubConstruct
Dim Typ As TypeConstruct
Dim Enm As EnumConstruct
Dim Evt As EventConstruct
Dim Cnt As ConstConstruct
Dim Dcl As DeclareConstruct
Dim Fnc As FunctionConstruct
Dim Prp As PropertyConstruct
Dim Ipl As ImplementsConstruct

With Builder
It_.VisitAccess Entity.Access
.Append IIf(Entity.IsClass, "Class ", "Module ")
It_.VisitId Entity.Id
.AppendLn
.Indent

If Entity.OptionBase <> 0 Then
.Append "Option Base "
.AppendLn Entity.OptionBase
End If

If Entity.OptionCompare <> vbBinaryCompare Then
.Append "Option Compare "
.AppendLn IIf(Entity.OptionCompare = vbBinaryCompare, "Binary", "Text")
End If

If Entity.OptionExplicit Then .AppendLn "Option Explicit"
.AppendLn
It_.VisitAttributes Entity, Nothing, Entity.Attributes

For Each Ipl In Entity.Impls
It_.VisitImplements Entity, Ipl
.AppendLn
Sep = True
Next

If Sep And Entity.Events.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Evt In Entity.Events
It_.VisitEvent Entity, Evt
.AppendLn
Sep = True
Next

If Sep And Entity.Types.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Typ In Entity.Types
It_.VisitType Entity, Typ
.AppendLn

Count = Count + 1
If Count <> Entity.Types.Count Then .AppendLn
Sep = True
Next

If Sep And Entity.Vars.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Var In Entity.Vars
It_.VisitDim Entity, Nothing, Var
.AppendLn
Sep = True
Next

If Sep And Entity.Consts.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Cnt In Entity.Consts
It_.VisitConst Entity, Nothing, Cnt
.AppendLn
Sep = True
Next

If Sep And Entity.Declares.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Dcl In Entity.Declares
It_.VisitDeclare Entity, Dcl
.AppendLn
Sep = True
Next

If Sep And Entity.Enums.Count > 0 Then
.AppendLn
Sep = False
End If

Count = 0

For Each Enm In Entity.Enums
It_.VisitEnum Entity, Enm
.AppendLn

Count = Count + 1
If Count <> Entity.Enums.Count Then .AppendLn
Sep = True
Next

If Sep And Entity.Functions.Count > 0 Then
.AppendLn
Sep = False
End If

Count = 0

For Each Fnc In Entity.Functions
It_.VisitAccess Fnc.Access
If Fnc.IsStatic Then .Append "Static "
If Fnc.IsDefault Then .Append "Default "
If Fnc.IsIterator Then .Append "Iterator "
.Append "Function "
It_.VisitId Fnc.Id
It_.VisitParams Entity, Fnc, Fnc.Parameters
.Append " As "
It_.VisitDataType Entity, Fnc, Fnc.DataType
.AppendLn
.Indent
It_.VisitAttributes Entity, Fnc, Fnc.Attributes
It_.VisitBody Entity, Fnc, Fnc.Body
.Deindent
.AppendLn "End Function"

Count = Count + 1
If Count <> Entity.Functions.Count Then .AppendLn
Sep = True
Next

If Sep And Entity.Subs.Count > 0 Then
.AppendLn
Sep = False
End If

Count = 0

For Each Prc In Entity.Subs
It_.VisitAccess Prc.Access
If Prc.IsStatic Then .Append "Static "
If Prc.IsDefault Then .Append "Default "
.Append "Sub "
It_.VisitId Prc.Id
It_.VisitParams Entity, Prc, Prc.Parameters
.AppendLn
.Indent
It_.VisitAttributes Entity, Prc, Prc.Attributes
It_.VisitBody Entity, Prc, Prc.Body
.Deindent
.AppendLn "End Sub"
Sep = True
Count = Count + 1
If Count <> Entity.Subs.Count Then .AppendLn
Next

If Sep And Entity.Properties.Count > 0 Then
.AppendLn
Sep = False
End If

Count = 0

For Each Slt In Entity.Properties
If Slt.Exists(VbGet) Then
Set Prp = Slt(VbGet)
It_.VisitAccess Prp.Access
If Prp.IsStatic Then .Append "Static "
If Prp.IsDefault Then .Append "Default "

.Append "Property Get "
It_.VisitId Slt.Id
It_.VisitParams Entity, Prp, Prp.Parameters
.Append " As "
It_.VisitDataType Entity, Prp, Prp.DataType
.AppendLn

.Indent
It_.VisitAttributes Entity, Prp, Prp.Attributes
It_.VisitBody Entity, Prp, Prp.Body
.Deindent
.AppendLn "End Property"

If Slt.Exists(VbLet) Or Slt.Exists(VbSet) Then .AppendLn
End If

If Slt.Exists(VbLet) Then
Set Prp = Slt(VbLet)
It_.VisitAccess Prp.Access
If Prp.IsStatic Then .Append "Static "
If Prp.IsDefault Then .Append "Default "

.Append "Property Let "
It_.VisitId Slt.Id
It_.VisitParams Entity, Prp, Prp.Parameters
.AppendLn

.Indent
It_.VisitBody Entity, Prp, Prp.Body
.Deindent
.AppendLn "End Property"
If Slt.Exists(VbSet) Then .AppendLn
End If

If Slt.Exists(VbSet) Then
Set Prp = Slt(VbSet)
It_.VisitAccess Prp.Access
If Prp.IsStatic Then .Append "Static "
If Prp.IsDefault Then .Append "Default "

.Append "Property Set "
It_.VisitId Slt.Id
It_.VisitParams Entity, Prp, Prp.Parameters
.AppendLn

.Indent
It_.VisitBody Entity, Prp, Prp.Body
.Deindent
.AppendLn "End Property"
End If

Count = Count + 1
If Count <> Entity.Properties.Count Then .AppendLn
Next

.Deindent
.Append "End "
.AppendLn IIf(Entity.IsClass, "Class", "Module")
End With
End Sub

Private Sub IVisitor_VisitEnum(ByVal Entity As Entity, ByVal Enm As EnumConstruct)
Dim Mem As EnumerandConstruct

It_.VisitAccess Enm.Access
Builder.Append "Enum "
It_.VisitId Enm.Id
Builder.AppendLn
Builder.Indent

For Each Mem In Enm.Enumerands
It_.VisitId Mem.Id

If Not Mem.Value Is Nothing Then
Builder.Append " = "
It_.VisitExpression vnConst, Entity, Nothing, Mem.Value
End If

Builder.AppendLn
Next

Builder.Deindent
Builder.Append "End Enum"
End Sub

Private Sub IVisitor_VisitErase(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As EraseConstruct)
Dim Count As Integer
Dim Var As Variable

Builder.Append "Erase "

For Each Var In Stmt.Vars
It_.VisitId Var.Id
Count = Count + 1
If Count <> Stmt.Vars.Count Then Builder.Append ", "
Next

Builder.Append " "
End Sub

Private Sub IVisitor_VisitEvent(ByVal Entity As Entity, ByVal Evt As EventConstruct)
It_.VisitAccess Evt.Access
Builder.Append "Event "
It_.VisitId Evt.Id
It_.VisitParams Entity, Nothing, Evt.Parameters
End Sub

Private Sub IVisitor_VisitExit(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ExitConstruct)
Builder.Append "Exit "

Select Case Stmt.What
Case ewDo
Builder.Append "Do "

Case ewFor
Builder.Append "For "

Case ewWhile
Builder.Append "While "

Case ewSub
Builder.Append "Sub "

Case ewFunction
Builder.Append "Function "

Case ewProperty
Builder.Append "Property "

Case ewSelect
Builder.Append "Select "
End Select
End Sub

Private Sub IVisitor_VisitExpression( _
ByVal ValidationType As ValidationNumbers, _
ByVal Entity As Entity, _
ByVal NullMethod As IMethod, _
ByVal Expr As IExpression, _
Optional ByVal IsLHS As Boolean, _
Optional ByVal Op As Operator _
)
Static Recurse As Integer
Dim Idx As Integer
Dim Bkp As Integer
Dim Exr As IExpression

If Recurse = 0 Then ValidateExpr ValidationType, Entity, NullMethod, Expr, IsLHS

Select Case Expr.Kind
Case ekLiteral
Dim Lit As Literal
Set Lit = Expr
It_.VisitToken Lit.Value

Case ekSymbol
Dim Sym As Symbol
Set Sym = Expr
It_.VisitToken Sym.Value

Case ekFileHandle
Dim Hnd As FileHandle
Set Hnd = Expr
Builder.Append "#"
It_.VisitToken Hnd.Value

Case ekTuple
Dim Tup As TupleConstruct
Set Tup = Expr

For Idx = 1 To Tup.Elements.Count
Set Exr = Tup.Elements(Idx)
Bkp = Recurse
Recurse = 0
ValidateExpr ValidationType, Entity, NullMethod, Expr, IsLHS
Recurse = Bkp
It_.VisitExpression ValidationType, Entity, NullMethod, Exr, IsLHS
If Idx <> Tup.Elements.Count Then Builder.Append ", "
Next

Case ekUnaryExpr
Dim Uni As UnaryExpression
Set Uni = Expr
It_.VisitOperator Uni.Operator
Recurse = Recurse + 1
It_.VisitExpression ValidationType, Entity, NullMethod, Uni.Value, IsLHS
Recurse = Recurse - 1

Case ekBinaryExpr
Dim Bin As BinaryExpression
Set Bin = Expr

Dim Par As Boolean
If Not Op Is Nothing Then Par = ComparePrecedence(Op, Bin.Operator) = 1
If Par Then Builder.Append "("

Recurse = Recurse + 1
It_.VisitExpression ValidationType, Entity, NullMethod, Bin.LHS, Op:=Bin.Operator
It_.VisitOperator Bin.Operator
It_.VisitExpression ValidationType, Entity, NullMethod, Bin.RHS, Op:=Bin.Operator
Recurse = Recurse - 1

If Par Then Builder.Append ")"

Case ekIndexer
It_.VisitCall Entity, NullMethod, Expr
End Select
End Sub

Private Sub IVisitor_VisitFor(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ForConstruct)
Dim Lit As Literal
Dim HasStep As Boolean

Builder.Append "For "
It_.VisitToken Stmt.Counter.Value
Builder.Append " = "
It_.VisitExpression vnLet, Entity, Method, Stmt.StartValue
Builder.Append " To "
It_.VisitExpression vnLet, Entity, Method, Stmt.EndValue

If Stmt.Increment.Kind = ekLiteral Then Set Lit = Stmt.Increment: HasStep = Lit.Value.Line <> 0 Or Lit.Value.Column <> 0

If HasStep Then
Builder.Append " Step "
It_.VisitExpression vnLet, Entity, Method, Stmt.Increment
End If

Builder.AppendLn
Builder.Indent

It_.VisitBody Entity, Method, Stmt.Body

Builder.Deindent
Builder.Append "Next"
End Sub

Private Sub IVisitor_VisitForEach(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ForEachConstruct)
Builder.Append "For Each "
It_.VisitToken Stmt.Element.Value
Builder.Append " In "
It_.VisitExpression vnVar, Entity, Method, Stmt.Group

Builder.AppendLn
Builder.Indent

It_.VisitBody Entity, Method, Stmt.Body

Builder.Deindent
Builder.Append "Next"
End Sub

Private Sub IVisitor_VisitGet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GetConstruct)
Builder.Append "Get "
It_.VisitExpression vnVar, Entity, Method, Stmt.FileNumber
Builder.Append ", "
If Not Stmt.RecNumber Is Nothing Then It_.VisitExpression vnHandle, Entity, Method, Stmt.RecNumber
Builder.Append ", "
It_.VisitToken Stmt.Var.Value
End Sub

Private Sub IVisitor_VisitGoSub(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GoSubConstruct)
Dim Label As LabelConstruct
Dim LinNum As LineNumberConstruct

Builder.Append "GoSub "

If Stmt.Target.Kind = snLineNumber Then
Set LinNum = Stmt.Target
It_.VisitToken LinNum.Value
Else
Set Label = Stmt.Target
It_.VisitId Label.Id
End If
End Sub

Private Sub IVisitor_VisitGoTo(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GoToConstruct)
Dim Label As LabelConstruct
Dim LinNum As LineNumberConstruct

Builder.Append "GoTo "

If Stmt.Target.Kind = snLineNumber Then
Set LinNum = Stmt.Target
It_.VisitToken LinNum.Value
Else
Set Label = Stmt.Target
It_.VisitId Label.Id
End If
End Sub

Private Sub IVisitor_VisitId(ByVal Id As Identifier)
If Not Id.Project Is Nothing Then
It_.VisitToken Id.Project
Builder.Append "."
End If

It_.VisitToken Id.Name
End Sub

Private Sub IVisitor_VisitIf(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As IfConstruct)
Dim Arm As IfArm
Dim SubStmt As IStmt
Dim Idx As Integer
Dim SingleLine As Boolean

If SingleLine Then
Set Arm = Stmt.Arms(1)
Builder.Append "If "
It_.VisitExpression vnLet, Entity, Method, Arm.Condition
Builder.Append " Then "
It_.VisitStmt Entity, Method, Arm.Body(1)

If Stmt.ElseBody.Count = 1 Then
Builder.Append " Else "
It_.VisitStmt Entity, Method, Stmt.ElseBody(1)
End If

Else
For Idx = 1 To Stmt.Arms.Count
Builder.Append IIf(Idx = 1, "If ", "ElseIf ")
Set Arm = Stmt.Arms(Idx)
It_.VisitExpression vnLet, Entity, Method, Arm.Condition
Builder.AppendLn " Then"

Builder.Indent
It_.VisitBody Entity, Method, Arm.Body
Builder.Deindent
Next

If Stmt.ElseBody.Count > 0 Then
Builder.AppendLn "Else"
Builder.Indent
It_.VisitBody Entity, Method, Stmt.ElseBody
Builder.Deindent
End If

Builder.Append "End If"
End If
End Sub

Private Sub IVisitor_VisitImplements(ByVal Entity As Entity, ByVal Ipl As ImplementsConstruct)
Builder.Append "Implements "
It_.VisitId Ipl.Id
End Sub

Private Sub IVisitor_VisitInput(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As InputConstruct)
Dim Count As Integer
Dim Var As Symbol

Builder.Append "Input "
It_.VisitExpression vnHandle, Entity, Method, Stmt.FileNumber
Builder.Append ", "

For Each Var In Stmt.Vars
It_.VisitToken Var.Value
Count = Count + 1
If Count <> Stmt.Vars.Count Then Builder.Append ", "
Next
End Sub

Private Sub IVisitor_VisitLabel(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LabelConstruct)
Builder.Append NameBank(Stmt.Id.Name)
Builder.Append ": "
End Sub

Private Sub IVisitor_VisitLet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LetConstruct)
It_.VisitExpression vnVar, Entity, Method, Stmt.Name, IsLHS:=True
It_.VisitOperator Stmt.Operator
It_.VisitExpression vnLet, Entity, Method, Stmt.Value
End Sub

Private Sub IVisitor_VisitLineNumber(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LineNumberConstruct)
It_.VisitToken Stmt.Value
End Sub

Private Sub IVisitor_VisitLock(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LockConstruct)
Builder.Append "Lock "
It_.VisitExpression vnHandle, Entity, Method, Stmt.FileNumber
Builder.Append ", "
It_.VisitExpression vnLet, Entity, Method, Stmt.RecordRange
End Sub

Private Sub IVisitor_VisitLSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LSetConstruct)
Builder.Append "LSet "
It_.VisitExpression vnVar, Entity, Method, Stmt.Name, IsLHS:=True
Builder.Append " = "
It_.VisitExpression vnVar, Entity, Method, Stmt.Value
End Sub

Private Sub IVisitor_VisitName(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As NameConstruct)
Builder.Append "Name "
It_.VisitExpression vnLet, Entity, Method, Stmt.OldPathName
Builder.Append " As "
It_.VisitExpression vnLet, Entity, Method, Stmt.NewPathName
End Sub

Private Sub IVisitor_VisitOnComputed(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OnComputedConstruct)
Dim Count As Integer
Dim Target As IStmt
Dim Label As LabelConstruct

Builder.Append "On "
It_.VisitExpression vnLet, Entity, Method, Stmt.Value

If Stmt.IsGoTo Then
Builder.Append " GoTo "
Else
Builder.Append " GoSub "
End If

For Each Target In Stmt.Targets
If Target.Kind = snLabel Then
Set Label = Target
It_.VisitId Label.Id
Else
It_.VisitLineNumber Entity, Method, Target
End If

Count = Count + 1
If Count <> Stmt.Targets.Count Then Builder.Append ", "
Next
End Sub

Private Sub IVisitor_VisitOnError(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OnErrorConstruct)
Builder.Append "On Error "

If Stmt.Statement.Kind = snGoTo Then
It_.VisitGoTo Entity, Method, Stmt.Statement

ElseIf Stmt.Statement.Kind = snResume Then
It_.VisitResume Entity, Method, Stmt.Statement
End If
End Sub

Private Sub IVisitor_VisitOpen(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OpenConstruct)
Builder.Append "Open "
It_.VisitExpression vnLet, Entity, Method, Stmt.PathName
Builder.Append " For "

Select Case Stmt.FileMode
Case fmAppend
Builder.Append "Append"

Case fmBinary
Builder.Append "Binary"

Case fmInput
Builder.Append "Input"

Case fmOutput
Builder.Append "Output"

Case fmRandom
Builder.Append "Random"
End Select

If Stmt.FileAccess <> faNone Then
Builder.Append " Access "

Select Case Stmt.FileAccess
Case faRead
Builder.Append "Read"

Case faReadWrite
Builder.Append "Read Write"

Case faWrite
Builder.Append "Write"
End Select
End If

Select Case Stmt.FileLock
Case flRead
Builder.Append " Read"

Case flReadWrite
Builder.Append " Read Write"

Case flShared
Builder.Append " Shared"

Case flWrite
Builder.Append " Write"
End Select

Builder.Append " As "
It_.VisitExpression vnHandle, Entity, Method, Stmt.FileNumber

If Not Stmt.Length Is Nothing Then
Builder.Append " Len="
It_.VisitExpression vnLet, Entity, Method, Stmt.Length
End If
End Sub

Private Sub IVisitor_VisitOperator(ByVal Stmt As Operator)
If Stmt.IsUnary Then
It_.VisitToken Stmt.Value

Select Case Stmt.Value.Code
Case opWithBang, opWithDot, opNeg
Rem OK

Case Else
Builder.Append " "
End Select

Else
Select Case Stmt.Value.Code
Case opDot, opBang, opNamed
It_.VisitToken Stmt.Value

Case Else
Builder.Append " "
It_.VisitToken Stmt.Value
Builder.Append " "
End Select
End If
End Sub

Private Sub IVisitor_VisitParams(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Params As KeyedList)
Dim Idx As Integer
Dim Parm As Parameter

Builder.Append "("

For Idx = 1 To Params.Count
Set Parm = Params(Idx)

If Parm.IsOptional Then
Builder.Append "Optional "

ElseIf Parm.IsParamArray Then
Builder.Append "ParamArray "
End If

If Not Parm.IsParamArray Then
Builder.Append IIf(Parm.IsByVal, "ByVal ", "ByRef ")
End If

It_.VisitId Parm.Id
If Parm.IsArray Then Builder.Append "()"

Builder.Append " As "
It_.VisitDataType Entity, NullMethod, Parm.DataType

If Not Parm.Init Is Nothing Then
Builder.Append " = "
It_.VisitExpression vnConst, Entity, NullMethod, Parm.Init
End If

If Idx <> Params.Count Then Builder.Append ", "
Next

Builder.Append ")"
End Sub

Private Sub IVisitor_VisitPrint(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As PrintConstruct)
Dim Count As Integer
Dim Arg As PrintArg

Builder.Append "Print "
It_.VisitExpression vnHandle, Entity, Method, Stmt.FileNumber
Builder.Append ", "

For Each Arg In Stmt.Output
Count = Count + 1

If Not Arg.Indent Is Nothing Then
Builder.Append IIf(Arg.Indent.IsTab, " Tab", " Spc")

If Not Arg.Indent.Value Is Nothing Then
Builder.Append "("
It_.VisitExpression vnLet, Entity, Method, Arg.Indent.Value
Builder.Append ")"
End If

Builder.Append " "
End If

It_.VisitExpression vnLet, Entity, Method, Arg.Value

If Arg.HasSemicolon Then Builder.Append ";"
If Count <> Stmt.Output.Count Then Builder.Append " "
Next
End Sub

Private Sub IVisitor_VisitPut(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As PutConstruct)
Builder.Append "Put "
It_.VisitExpression vnHandle, Entity, Method, Stmt.FileNumber
Builder.Append ", "
If Not Stmt.RecNumber Is Nothing Then It_.VisitExpression vnLet, Entity, Method, Stmt.RecNumber
Builder.Append ", "
It_.VisitToken Stmt.Var.Value
End Sub

Private Sub IVisitor_VisitRaiseEvent(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As RaiseEventConstruct)
Dim Count As Integer
Dim Expr As IExpression

Builder.Append "RaiseEvent "
It_.VisitId Stmt.Id

If Stmt.Arguments.Count > 0 Then
Builder.Append "("

For Each Expr In Stmt.Arguments
It_.VisitExpression vnLet, Entity, Method, Expr
Count = Count + 1
If Count <> Stmt.Arguments.Count Then Builder.Append ", "
Next

Builder.Append ")"
End If

Builder.Append " "
End Sub

Private Sub IVisitor_VisitReDim(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ReDimConstruct)
Dim Count As Integer
Dim Var As Variable

Builder.Append "ReDim "
If Stmt.HasPreserve Then Builder.Append "Preserve "

For Each Var In Stmt.Vars
It_.VisitId Var.Id
It_.VisitSubscripts Entity, Method, Var.Subscripts
Builder.Append " As "
It_.VisitDataType Entity, Method, Var.DataType
Count = Count + 1
If Count <> Stmt.Vars.Count Then Builder.Append ", "
Next
End Sub

Private Sub IVisitor_VisitReset(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ResetConstruct)
Builder.Append "Reset "
End Sub

Private Sub IVisitor_VisitResume(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ResumeConstruct)
Dim Label As LabelConstruct
Dim LinNum As LineNumberConstruct

Builder.Append "Resume"

If Stmt.IsNext Then
Builder.Append " Next "

ElseIf Stmt.Target.Kind = snLabel Then
Builder.Append " "
Set Label = Stmt.Target
It_.VisitId Label.Id
Else
Set LinNum = Stmt.Target

If LinNum.Value.Text <> "+0" Then
Builder.Append " "
It_.VisitToken LinNum.Value
End If
End If
End Sub

Private Sub IVisitor_VisitReturn(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ReturnConstruct)
Builder.Append "Return "
End Sub

Private Sub IVisitor_VisitRSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As RSetConstruct)
Builder.Append "RSet "
It_.VisitExpression vnVar, Entity, Method, Stmt.Name, IsLHS:=True
Builder.Append " = "
It_.VisitExpression vnVar, Entity, Method, Stmt.Value
End Sub

Private Sub IVisitor_VisitSeek(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SeekConstruct)
Builder.Append "Seek "
It_.VisitExpression vnHandle, Entity, Method, Stmt.FileNumber
Builder.Append ", "
It_.VisitExpression vnLet, Entity, Method, Stmt.Position
End Sub

Private Sub IVisitor_VisitSelect(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SelectConstruct)
Dim Count As Integer
Dim Cond As IExpression
Dim Cs As CaseConstruct
Dim Bin As BinaryExpression

Builder.Append "Select Case "
It_.VisitExpression vnLet, Entity, Method, Stmt.Value
Builder.AppendLn
Builder.Indent

For Each Cs In Stmt.Cases
Count = 0
Builder.Append "Case "

For Each Cond In Cs.Conditions
Count = Count + 1

If Cond.Kind = ekBinaryExpr Then
Set Bin = Cond

If Bin.LHS Is Nothing Then
Builder.Append "Is"
It_.VisitOperator Bin.Operator
Set Cond = Bin.RHS
End If
End If

It_.VisitExpression vnLet, Entity, Method, Cond
If Count <> Cs.Conditions.Count Then Builder.Append ", "
Next

Builder.AppendLn
Builder.Indent
It_.VisitBody Entity, Method, Cs.Body
Builder.Deindent
Next

If Stmt.CaseElse.Count > 0 Then
Builder.AppendLn "Case Else"
Builder.Indent
It_.VisitBody Entity, Method, Stmt.CaseElse
Builder.Deindent
End If

Builder.Deindent
Builder.Append "End Select"
End Sub

Private Sub IVisitor_VisitSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SetConstruct)
Builder.Append "Set "
It_.VisitExpression vnSet, Entity, Method, Stmt.Name, IsLHS:=True
Builder.Append " = "
It_.VisitExpression vnSet, Entity, Method, Stmt.Value
End Sub

Private Sub IVisitor_VisitSource(ByVal Source As SourceFile)
Dim Idx As Integer
Dim Ent As Entity

For Idx = 1 To Source.Entities.Count
Set Ent = Source.Entities(Idx)
It_.VisitEntity Ent
If Idx <> Source.Entities.Count Then Builder.AppendLn
Next
End Sub

Private Sub IVisitor_VisitStmt(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As IStmt)
Select Case Stmt.Kind
Case snCall
Builder.Append "Call "
It_.VisitCall Entity, Method, Stmt

Case snClose
It_.VisitClose Entity, Method, Stmt

Case snConst
It_.VisitConst Entity, Method, Stmt

Case snContinue
It_.VisitContinue Entity, Method, Stmt

Case snDebug
It_.VisitDebug Entity, Method, Stmt

Case snDim
It_.VisitDim Entity, Method, Stmt

Case snDo
It_.VisitDo Entity, Method, Stmt

Case snEnd
It_.VisitEnd Entity, Method, Stmt

Case snErase
It_.VisitErase Entity, Method, Stmt

Case snExit
It_.VisitExit Entity, Method, Stmt

Case snFor
It_.VisitFor Entity, Method, Stmt

Case snForEach
It_.VisitForEach Entity, Method, Stmt

Case snGet
It_.VisitGet Entity, Method, Stmt

Case snGoSub
It_.VisitGoSub Entity, Method, Stmt

Case snGoTo
It_.VisitGoTo Entity, Method, Stmt

Case snIf
It_.VisitIf Entity, Method, Stmt

Case snInput
It_.VisitInput Entity, Method, Stmt

Case snLabel
It_.VisitLabel Entity, Method, Stmt

Case snLet
It_.VisitLet Entity, Method, Stmt

Case snLineNumber
It_.VisitLineNumber Entity, Method, Stmt

Case snLock
It_.VisitLock Entity, Method, Stmt

Case snLSet
It_.VisitLSet Entity, Method, Stmt

Case snName
It_.VisitName Entity, Method, Stmt

Case snOnError
It_.VisitOnError Entity, Method, Stmt

Case snOnComputed
It_.VisitOnComputed Entity, Method, Stmt

Case snOpen
It_.VisitOpen Entity, Method, Stmt

Case snPrint
It_.VisitPrint Entity, Method, Stmt

Case snPut
It_.VisitPut Entity, Method, Stmt

Case snRaiseEvent
It_.VisitRaiseEvent Entity, Method, Stmt

Case snReDim
It_.VisitReDim Entity, Method, Stmt

Case snReset
It_.VisitReset Entity, Method, Stmt

Case snResume
It_.VisitResume Entity, Method, Stmt

Case snReturn
It_.VisitReturn Entity, Method, Stmt

Case snRSet
It_.VisitRSet Entity, Method, Stmt

Case snSeek
It_.VisitSeek Entity, Method, Stmt

Case snSelect
It_.VisitSelect Entity, Method, Stmt

Case snSet
It_.VisitSet Entity, Method, Stmt

Case snStop
It_.VisitStop Entity, Method, Stmt

Case snUnlock
It_.VisitUnlock Entity, Method, Stmt

Case snWhile
It_.VisitWhile Entity, Method, Stmt

Case snWidth
It_.VisitWidth Entity, Method, Stmt

Case snWith
It_.VisitWith Entity, Method, Stmt

Case snWrite
It_.VisitWrite Entity, Method, Stmt
End Select
End Sub

Private Sub IVisitor_VisitStop(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As StopConstruct)
Builder.Append "Stop "
End Sub

Private Sub IVisitor_VisitSubscripts(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Subscripts As KeyedList)
Dim Idx As Integer
Dim Pair As SubscriptPair

If Subscripts.Count = 0 Then Exit Sub

Builder.Append "("

For Idx = 1 To Subscripts.Count
Set Pair = Subscripts(Idx)

It_.VisitExpression vnLet, Entity, NullMethod, Pair.LowerBound
Builder.Append " To "
It_.VisitExpression vnLet, Entity, NullMethod, Pair.UpperBound

If Idx <> Subscripts.Count Then Builder.Append ", "
Next

Builder.Append ")"
End Sub

Private Sub IVisitor_VisitToken(ByVal Stmt As Token)
Select Case Stmt.Kind
Case tkBinaryNumber
If Left$(Stmt.Text, 1) = "-" Then Builder.Append "-"
Builder.Append "&B"
Builder.Append Mid$(Stmt.Text, 2)

Case tkDateTime
Builder.Append "#"
Builder.Append Stmt.Text
Builder.Append "#"

Case tkEscapedIdentifier, tkCrazyIdentifier
Builder.Append "["
Builder.Append NameBank(Stmt)
Builder.Append "]"

Case tkFileHandle, tkFloatNumber, tkIntegerNumber, tkSciNumber
If Left$(Stmt.Text, 1) = "+" Then
Builder.Append Mid$(Stmt.Text, 2)
Else
Builder.Append Stmt.Text
End If

Case tkHexaNumber
If Left$(Stmt.Text, 1) = "-" Then Builder.Append "-"
Builder.Append "&H"
Builder.Append Mid$(Stmt.Text, 2)

Case tkIdentifier, tkKeyword
Builder.Append NameBank(Stmt)

Case tkOperator
Builder.Append Replace(NameBank(Stmt), "~", "")

Case tkOctalNumber
If Left$(Stmt.Text, 1) = "-" Then Builder.Append "-"
Builder.Append "&O"
Builder.Append Mid$(Stmt.Text, 2)

Case tkString
Builder.Append """"
Builder.Append Replace(Stmt.Text, """", """""""")
Builder.Append """"

Case Else
Debug.Assert False
Err.Raise 5, "Reverter.VisitToken"
End Select

If Stmt.Suffix <> vbNullChar Then Builder.Append Stmt.Suffix
End Sub

Private Sub IVisitor_VisitType(ByVal Entity As Entity, ByVal Typ As TypeConstruct)
Dim Mem As Variable

It_.VisitAccess Typ.Access
Builder.Append "Type "
It_.VisitId Typ.Id
Builder.AppendLn
Builder.Indent

For Each Mem In Typ.Members
It_.VisitId Mem.Id
Builder.Append " As "
It_.VisitDataType Entity, Nothing, Mem.DataType

If Mem.DataType.IsArray And Mem.Subscripts.Count = 0 Then
Builder.Append "()"
Else
It_.VisitSubscripts Entity, Nothing, Mem.Subscripts
End If

Builder.AppendLn
Next

Builder.Deindent
Builder.Append "End Type"
End Sub

Private Sub IVisitor_VisitUnlock(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As UnlockConstruct)
Builder.Append "Unlock "
It_.VisitExpression vnHandle, Entity, Method, Stmt.FileNumber
Builder.Append ", "
It_.VisitExpression vnLet, Entity, Method, Stmt.RecordRange
End Sub

Private Sub IVisitor_VisitWhile(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WhileConstruct)
Builder.Append "While "
It_.VisitExpression vnLet, Entity, Method, Stmt.Condition

Builder.AppendLn
Builder.Indent

It_.VisitBody Entity, Method, Stmt.Body

Builder.Deindent
Builder.Append "Wend"
End Sub

Private Sub IVisitor_VisitWidth(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WidthConstruct)
Builder.Append "Width "
It_.VisitExpression vnHandle, Entity, Method, Stmt.FileNumber
Builder.Append ", "
It_.VisitExpression vnLet, Entity, Method, Stmt.Value
End Sub

Private Sub IVisitor_VisitWith(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WithConstruct)
Builder.Append "With "
It_.VisitExpression vnVar, Entity, Method, Stmt.PinObject
Builder.AppendLn

Builder.Indent
It_.VisitBody Entity, Method, Stmt.Body
Builder.Deindent

Builder.Append "End With"
End Sub

Private Sub IVisitor_VisitWrite(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WriteConstruct)
Dim Count As Integer
Dim Expr As IExpression

Builder.Append "Write "
It_.VisitExpression vnHandle, Entity, Method, Stmt.FileNumber
Builder.Append ", "

For Each Expr In Stmt.Output
It_.VisitExpression vnLet, Entity, Method, Expr
Count = Count + 1
If Count <> Stmt.Output.Count Then Builder.Append ", "
Next
End Sub
End Class


Public Class RSetConstruct
Option Explicit
Implements IStmt

Public Name As IExpression
Public Value As IExpression

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


Public Class Scanner
Option Explicit

Private Const Msg_ = "Invalid literal"

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 ZERO_ As Integer = 48
Private Const NINE_ As Integer = 57
Private Const CRLF_ As Long = &HA000D

Private File_ As Integer
Private RunningLine_ As Long
Private RunningColumn_ As Long
Private FrozenColumn_ As Long
Private PreviousColumn_ As Long
Private FilePath_ As String

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
kwDeclare ' 18
kwDefault ' 19
kwDefBool ' 20
kwDefByte ' 21
kwDefCur ' 22
kwDefDate ' 23
kwDefDbl ' 24
kwDefDec ' 25
kwDefInt ' 26
kwDefLng ' 27
kwDefLngLng ' 28
kwDefLngPtr ' 29
kwDefObj ' 30
kwDefSng ' 31
kwDefStr ' 32
kwDefVar ' 33
kwDim ' 34
kwDo ' 35
kwDouble ' 36
kwEach ' 37
kwElse ' 38
kwElseIf ' 39
kwEmpty ' 40
kwEnd ' 41
kwEndIf ' 42
kwEnum ' 43
kwErase ' 44
kwEvent ' 45
kwExit ' 46
kwFalse ' 47
kwFor ' 48
kwFriend ' 49
kwFunction ' 50
kwGet ' 51
kwGlobal ' 52
kwGoSub ' 53
kwGoTo ' 54
kwIf ' 55
kwImplements ' 56
kwIn ' 57
kwInput ' 58
kwInteger ' 59
kwIterator ' 60
kwLet ' 61
kwLocal ' 62
kwLong ' 63
kwLongLong ' 64
kwLongPtr ' 65
kwLoop ' 66
kwLSet ' 67
kwMe ' 68
kwModule ' 69
kwNext ' 70
kwNothing ' 71
kwNull ' 72
kwOn ' 73
kwOpen ' 74
kwOption ' 75
kwOptional ' 76
kwParamArray ' 77
kwPreserve ' 78
kwPrint ' 79
kwPrivate ' 80
kwPSet ' 81
kwPublic ' 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
cxSpc '23 / 135
cxStep '24 / 136
cxTab '25 / 137
cxText '26 / 138
cxWidth '27 / 139
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
opIdentity '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()
RunningLine_ = 1
RunningColumn_ = 1
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

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

Public Function GetToken(Optional ByVal ReturnInlineComment As Boolean) 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)
Debug.Assert Token.Text <> ""

Rem Removing leading zeros in excess
Do While Left$(Token.Text, 1) = "0"
Token.Text = Mid$(Token.Text, 2)
Loop

Select Case Left$(Token.Text, 1)
Case "", "."
Token.Text = "0" & Token.Text
End Select

If Token.Code = 0 Then
Select Case Token.Kind
Case tkIntegerNumber
Select Case Right$(String$(18, "0") & Token.Text, 19)
Case Is <= "0000000000000032767"
Token.Code = vbInteger

Case Is <= "0000000002147483647"
Token.Code = vbLong

Case Is <= "9223372036854775807"
Token.Code = vbLongLong

Case Else
Token.Code = vbDouble
End Select

Case tkBinaryNumber
Select Case Len(Token.Text)
Case Is > 64
Token.Code = vbDouble

Case Is > 32
Token.Code = vbLongLong

Case Is > 16
Token.Code = vbLong

Case Else
Token.Code = vbInteger
End Select

Case tkOctalNumber
Select Case Right$(String(21, "0") & Token.Text, 19)
Case Is <= "000000000000000077777"
Token.Code = vbInteger

Case Is <= "000000000017777777777"
Token.Code = vbLong

Case Is <= "177777777777777777777"
Token.Code = vbLongLong

Case Else
Token.Code = vbDouble
End Select

Case tkHexaNumber
Select Case Len(Token.Text)
Case Is > 16
Token.Code = vbDouble

Case Is > 8
Token.Code = vbLongLong

Case Is > 4
Token.Code = vbLong

Case Else
Token.Code = vbInteger
End Select

Case tkFloatNumber, tkSciNumber
Token.Code = vbDouble

Case Else
Rem It should not happen
Debug.Assert False
End Select
End If

Token.Text = "+" & Token.Text

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 "`"
Set Token = ReadInlineComment

If Not ReturnInlineComment Then
Done = False
Set Token = New Token
End If

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
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 Until 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
Cp = GetCodePoint
Ch = ToChar(Cp)

Rem A!B scenario
If IsLetter(Cp) Then
UngetChar Ch
UngetChar "!"
Suffix = vbNullChar
Else
UngetChar Ch
End If

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

Case Else
UngetChar Ch
End Select

Set Result = NewToken(tkIdentifier, Suffix:=Suffix)
Name = Left$(Buffer, Count)
Index = NameBank.Keywords.IndexOf(Name)

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

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

If Index <> 0 Then
Index = Index + NameBank.Keywords.Count
Else
Index = NameBank.Ids.IndexOf(Name)

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

Index = Index + NameBank.Contextuals.Count + NameBank.Keywords.Count
End If
End If
End If

Select Case Result.Kind
Case tkKeyword, tkOperator
If Result.Suffix <> vbNullChar Then
If Index = kwString And Result.Suffix = "$" Then
Result.Kind = tkIdentifier
Index = NameBank.Ids.IndexOf(v.String) + NameBank.Contextuals.Count + NameBank.Keywords.Count

ElseIf Index = kwDate And Result.Suffix = "$" Then
Result.Kind = tkIdentifier
Index = NameBank.Ids.IndexOf(v.Date) + NameBank.Contextuals.Count + NameBank.Keywords.Count

Else
Fail "Keyword or operator cannot have type-declaration character"
End If
End If
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
Dim Result As TokenKind

Result = tkEscapedIdentifier

Do Until AtEnd
Cp = GetCodePoint

Select Case Cp
Case US_, ZERO_ To NINE_
Rem OK

Case AscW("]")
Exit Do

Case LF_
Fail "Invalid identifier"

Case Else
If Not IsLetter(Cp) Then If Not IsSurrogate(Cp) Then Result = tkCrazyIdentifier
End Select

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(Result, 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

Token.Code = Token.Code + NameBank.Contextuals.Count + NameBank.Keywords.Count
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
Token.Text = "+" & Token.Text

Case "o", "O"
Set Token = ReadOctal
Token.Text = "+" & Token.Text

Case "h", "H"
Set Token = ReadHexa
Token.Text = "+" & Token.Text

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
Static Chars As KeyedList

If Chars Is Nothing Then
Set Chars = New KeyedList
Chars.AddKVPairs "0", "0", "1", "1"
End If

Set ReadBin = ReadBOH(Chars, 96, tkBinaryNumber)
End Function

Private Function ReadOctal()
Static Chars As KeyedList

If Chars Is Nothing Then
Set Chars = New KeyedList
Chars.AddKVPairs "0", "0", "1", "1", "2", "2", "3", "3", "4", "4", "5", "5", "6", "6", "7", "7"
End If

Set ReadOctal = ReadBOH(Chars, 32, tkOctalNumber)
End Function

Private Function ReadHexa() As Token
Static Chars As KeyedList

If Chars Is Nothing Then
Set Chars = New KeyedList
Chars.AddKVPairs "0", "0", "1", "1", "2", "2", "3", "3", "4", "4", "5", "5", "6", "6", "7", "7", "8", "8", "9", "9", _
"a", "a", "b", "b", "c", "c", "d", "d", "e", "e", "f", "f", _
"A", "A", "B", "B", "C", "C", "D", "D", "E", "E", "F", "F"
End If

Set ReadHexa = ReadBOH(Chars, 24, tkHexaNumber)
End Function

Private Function ReadHash() As Token
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$(v.If), UCase$(v.ElseIf), UCase$(v.Else), UCase$(v.End), UCase$(v.Const)
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
Rem TODO: Can ReadDate scan more than one character?
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
Dim YYYY As Integer
Dim MM As Integer
Dim DD As Integer
Dim Result As String
Dim Ch As String * 1
Dim SecondNumber As Token
Dim ThirdNumber As Token

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
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 Until 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 ByVal 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 Text As String
Dim Ch As String * 1
Dim Buffer As String * MAX_LENGTH

If IsRem Then
Text = v.[Rem] & " "
Else
Text = " '"
End If

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

Do Until 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 Function ReadInlineComment() As Token
Dim Count As Long
Dim Ch As String * 1
Dim Token As Token

Set Token = NewToken(tkInlineComment)
Count = 1

Do Until AtEnd
Ch = GetChar

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

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

Token.Text = Token.Text & Ch
Loop

Set ReadInlineComment = Token
End Function

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

Private Function ReadBOH(ByVal AllowedChars As KeyedList, ByVal MaxLength As Integer, ByVal Kind As TokenKind) As Token
Dim Skip As Boolean
Dim Count As Integer
Dim Ch As String * 1
Dim Suffix As String * 1
Dim Buffer As String * 96

Skip = True

Do Until AtEnd
If Count = MaxLength Then Fail "Literal too long"
Ch = GetChar

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

Case "_"
Rem We'll ignore it

Case "0"
If Not Skip Then GoTo 10

Case Else
If Not AllowedChars.Exists(Ch) Then
UngetChar Ch
Exit Do
End If

Skip = False
10
Count = Count + 1
Mid$(Buffer, Count, 1) = Ch
End Select
Loop

If Skip Then
Count = 1
Mid$(Buffer, Count, 1) = "0"
End If

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


Public Class SeekConstruct
Option Explicit
Implements IStmt

Public FileNumber As IExpression
Public Position As IExpression

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


Public Class SelectConstruct
Option Explicit
Implements IStmt

Private Cases_ As KeyedList
Private CaseElse_ As KeyedList

Public Value As IExpression

Private Sub Class_Initialize()
Set Cases_ = New KeyedList
Set Cases_.T = NewValidator(TypeName(New CaseConstruct))

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

Public Property Get Cases() As KeyedList
Set Cases = Cases_
End Property

Public Property Get CaseElse() As KeyedList
Set CaseElse = CaseElse_
End Property

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


Public Class SetConstruct
Option Explicit
Implements IStmt

Public Name As IExpression
Public Value As IExpression

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

Public Sub Accept(ByVal Visitor As IVisitor)
Visitor.VisitSource Me
End Sub
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
Implements IMethod

Private Parms_ As KeyedList
Private Body_ As KeyedList
Private Attributes_ 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

Set Attributes_ = New KeyedList
Set Attributes_.T = NewValidator(TypeName(New AttributeConstruct))
End Sub

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

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

Public Property Get Attributes() As KeyedList
Set Attributes = Attributes_
End Property

Private Property Get IMethod_Access() As Accessibility
IMethod_Access = Access
End Property

Private Property Get IMethod_DataType() As DataType
Dim Token As Token
Dim Result As DataType

Set Token = New Token
Token.Kind = tkKeyword
Token.Code = kwVoid

Set Result = New DataType
Set Result.Id = NewId(Token)

Set IMethod_DataType = Result
End Property

Private Property Get IMethod_Id() As Identifier
Set IMethod_Id = Id
End Property

Private Property Get IMethod_Kind() As VbCallType
Rem Left intentionally empty
End Property

Private Property Get IMethod_Parameters() As KeyedList
Set IMethod_Parameters = Parms_
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
Public RowType As RowNumbers

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


Public Class SymRow
Option Explicit

Public Enum RowNumbers
rnImplicit
rnBuiltin
rnResult
rnParameter
rnVariable
rnConst
rnSub
rnFunction
rnPropertyGet
rnPropertyLet
rnPropertySet
rnDeclareSub
rnDeclareFunction
rnEnum
rnEnumerand
rnType
rnClass
rnMe
rnModule
rnString 'Id after "!"
rnNamedArg
rnLateBind 'Object or Variant
End Enum

Public Enum ScopeLevel
slGlobal
slEntity
slMethod
End Enum

Public Id As Long
Public Name As Long
Public Entity As Long
Public RowType As RowNumbers
Public Parent As Long
Public Indirect As Long
Public Method As Long
Public Access As Accessibility
Public Flags As Long '1=Default, 2=IsArray

Public Property Get Level() As ScopeLevel
Level = slGlobal

If Access = acPublic Then
If Entity = 0 Then Exit Property
If SymTable(Entity).RowType = rnModule Then Exit Property
End If

Level = slMethod
If Method <> 0 Then Exit Property

Level = slEntity
End Property
End Class


Public Class SymTable
Option Explicit

Private Const STD_LIB = 0&
Private Const IND_VOID = 0&

Private Type Entry
Id As Long
Name As Long
Entity As Long
RowType As RowNumbers
Parent As Long
Indirect As Long
Method As Long
Access As Accessibility
DataType As DataType
Flags As Long '1=Default, 2=IsArray
End Type

Private Ptr_ As Long
Private Cap_ As Long
Private Entries_() As Entry

Private Sub Class_Initialize()
Dim Builtin As Variant
Dim Builtins As Variant
Dim Entry As Entry

Cap_ = 4096
ReDim Entries_(1 To Cap_)

Builtins = Array(kwBoolean, kwByte, kwInteger, kwLong, kwLongLong, kwLongPtr, _
kwCurrency, cxDecimal, kwSingle, kwDouble, kwDate, kwString, cxObject, kwVariant)

For Each Builtin In Builtins
Ptr_ = Ptr_ + 1

With Entries_(Ptr_)
.Id = Ptr_
.Name = Builtin
.RowType = rnBuiltin
.Access = Accessibility.acPublic
End With
Next
End Sub

Private Sub AddEntity(ByVal Construct As Entity)
IncrementPtr

With Entries_(Ptr_)
.Id = Ptr_
.Name = Construct.Id.Name.Code
.RowType = IIf(Construct.IsClass, rnClass, rnModule)
.Access = Construct.Access
End With
End Sub

Private Sub AddConst(ByVal Panel As ControlPanel, ByVal Construct As ConstConstruct)
Dim Method As Long

If Not Panel.Method Is Nothing Then Method = Panel.Method.Id.Name.Code
IncrementPtr

With Entries_(Ptr_)
.Id = Ptr_
.Name = Construct.Id.Name.Code
.Entity = Panel.Entity.Id.Name.Code
.RowType = rnConst
If Not Construct.DataType Is Nothing Then _
.Indirect = FindFirst( _
Name:=Construct.DataType.Id.Name.Code, _
Entity:=STD_LIB, _
RowType:=rnBuiltin, _
Method:=Method, _
Access:=acPublic _
)

If Not Panel.Method Is Nothing Then .Method = MethodID(.Entity, Panel.Method)
.Access = Construct.Access
If .Indirect = 0 Then Set .DataType = Construct.DataType
End With
End Sub

Private Sub AddVar(ByVal Panel As ControlPanel, ByVal Construct As Variable, ByVal Parent As TypeConstruct)
IncrementPtr

With Entries_(Ptr_)
.Id = Ptr_
.Name = Construct.Id.Name.Code
.Entity = Panel.Entity.Id.Name.Code
.RowType = rnVariable
If Construct.IsDefault Then .Flags = 1

If Not Construct.DataType Is Nothing Then _
If Construct.DataType.IsArray Then _
.Flags = .Flags Or 2

.Indirect = FindDataType( _
Name:=Construct.DataType.Id.Name.Code, _
Entity:=Panel.Entity.Id.Name.Code, _
Access:=Construct.Access _
)

If Not Parent Is Nothing Then _
.Parent = FindFirst( _
Name:=Parent.Id.Name.Code, _
Entity:=.Entity, _
RowType:=rnType, _
Access:=Parent.Access _
)

If Not Panel.Method Is Nothing Then _
If Not Panel.Method.Id Is Nothing Then _
.Method = MethodID(.Entity, Panel.Method)

.Access = Construct.Access
If .Indirect = 0 Then Set .DataType = Construct.DataType
End With
End Sub

Private Sub AddSub(ByVal Panel As ControlPanel, ByVal Construct As SubConstruct)
Dim Parm As Parameter

IncrementPtr

With Entries_(Ptr_)
.Id = Ptr_
.Name = Construct.Id.Name.Code
.Entity = Panel.Entity.Id.Name.Code
.RowType = rnSub
.Access = Construct.Access
If Construct.IsDefault Then .Flags = 1
End With

Set Panel.Method = Construct

For Each Parm In Construct.Parameters
SymTable.Add Parm, Panel
Next
End Sub

Private Sub AddFunc(ByVal Panel As ControlPanel, ByVal Construct As FunctionConstruct)
Dim Parm As Parameter

IncrementPtr

With Entries_(Ptr_)
.Id = Ptr_
.Name = Construct.Id.Name.Code
.Entity = Panel.Entity.Id.Name.Code
.RowType = rnFunction
If Construct.IsDefault Then .Flags = 1
.Indirect = FindDataType( _
Name:=Construct.DataType.Id.Name.Code, _
Entity:=.Entity, _
Access:=Construct.Access _
)
.Access = Construct.Access
If .Indirect = 0 Then Set .DataType = Construct.DataType
End With

Set Panel.Method = Construct

For Each Parm In Construct.Parameters
SymTable.Add Parm, Panel
Next
End Sub

Private Sub AddProp(ByVal Panel As ControlPanel, ByVal Construct As PropertyConstruct)
Dim Parm As Parameter

IncrementPtr

With Entries_(Ptr_)
.Id = Ptr_
.Name = Construct.Id.Name.Code
.Entity = Panel.Entity.Id.Name.Code
If Construct.IsDefault Then .Flags = 1

Select Case Panel.Method.Kind
Case VbGet
.RowType = rnPropertyGet
.Indirect = FindDataType( _
Name:=Construct.DataType.Id.Name.Code, _
Entity:=.Entity, _
Access:=Construct.Access _
)
If .Indirect = 0 Then Set .DataType = Construct.DataType

Case VbLet
.RowType = rnPropertyLet
.Indirect = IND_VOID

Case VbSet
.RowType = rnPropertySet
.Indirect = IND_VOID
End Select

.Access = Construct.Access
End With

Set Panel.Method = Construct

For Each Parm In Construct.Parameters
SymTable.Add Parm, Panel
Next
End Sub

Private Sub AddDeclare(ByVal Panel As ControlPanel, ByVal Construct As DeclareConstruct)
IncrementPtr

With Entries_(Ptr_)
.Id = Ptr_
.Name = Construct.Id.Name.Code
.Entity = Panel.Entity.Id.Name.Code
.RowType = IIf(Construct.IsSub, rnDeclareSub, rnDeclareFunction)

If Not Construct.IsSub Then
.Indirect = FindDataType( _
Name:=Construct.DataType.Id.Name.Code, _
Entity:=.Entity, _
Access:=Construct.Access _
)
If .Indirect = 0 Then Set .DataType = Construct.DataType
End If

.Access = Construct.Access
End With
End Sub

Private Sub AddParm(ByVal Panel As ControlPanel, ByVal Construct As Parameter)
IncrementPtr

With Entries_(Ptr_)
.Id = Ptr_
.Name = Construct.Id.Name.Code
.Entity = Panel.Entity.Id.Name.Code
.RowType = rnParameter
If Construct.IsArray Then .Flags = 2
.Indirect = FindDataType( _
Name:=Construct.DataType.Id.Name.Code, _
Entity:=.Entity, _
Access:=acLocal _
)

Debug.Assert Not Panel.Method Is Nothing
.Method = MethodID(.Entity, Panel.Method)
If .Indirect = 0 Then Set .DataType = Construct.DataType
End With
End Sub

Private Sub AddEnum(ByVal Panel As ControlPanel, ByVal Construct As EnumConstruct)
IncrementPtr

With Entries_(Ptr_)
.Id = Ptr_
.Name = Construct.Id.Name.Code
.Entity = Panel.Entity.Id.Name.Code
.RowType = rnEnum
.Access = Construct.Access
End With
End Sub

Private Sub AddEnumerand(ByVal Panel As ControlPanel, ByVal Parent As EnumConstruct, ByVal Construct As EnumerandConstruct)
IncrementPtr

With Entries_(Ptr_)
.Id = Ptr_
.Name = Construct.Id.Name.Code
.Entity = Panel.Entity.Id.Name.Code
.Parent = Parent.Id.Name.Code
.RowType = rnEnumerand
.Access = Construct.Access
End With
End Sub

Private Sub AddType(ByVal Panel As ControlPanel, ByVal Construct As TypeConstruct)
IncrementPtr

With Entries_(Ptr_)
.Id = Ptr_
.Name = Construct.Id.Name.Code
.Entity = Panel.Entity.Id.Name.Code
.RowType = rnType
.Access = Construct.Access
End With
End Sub

Public Sub Add(ByVal Construct As Variant, Optional ByVal Panel As ControlPanel, Optional ByVal Parent As Object)
If TypeOf Construct Is ConstConstruct Then
AddConst Panel, Construct

ElseIf TypeOf Construct Is Variable Then
AddVar Panel, Construct, Parent

ElseIf TypeOf Construct Is SubConstruct Then
AddSub Panel, Construct

ElseIf TypeOf Construct Is FunctionConstruct Then
AddFunc Panel, Construct

ElseIf TypeOf Construct Is PropertyConstruct Then
AddProp Panel, Construct

ElseIf TypeOf Construct Is EnumerandConstruct Then
AddEnumerand Panel, Parent, Construct

ElseIf TypeOf Construct Is DeclareConstruct Then
AddDeclare Panel, Construct

ElseIf TypeOf Construct Is Parameter Then
AddParm Panel, Construct

ElseIf TypeOf Construct Is Entity Then
AddEntity Construct

ElseIf TypeOf Construct Is TypeConstruct Then
AddType Panel, Construct

ElseIf TypeOf Construct Is EnumConstruct Then
AddEnum Panel, Construct

Else
Rem It should not happen
Debug.Assert False
End If
End Sub

Public Default Property Get Item(ByVal Index As Long) As SymRow
Dim Result As SymRow

Set Result = New SymRow

With Entries_(Index)
Result.Id = .Id
Result.Name = .Name
Result.Parent = .Parent
Result.Entity = .Entity
Result.RowType = .RowType
Result.Indirect = .Indirect
Result.Method = .Method
Result.Access = .Access
Result.Flags = .Flags
End With

Set Item = Result
End Property

Private Function FindFirst( _
ByVal Name As Long, _
Optional ByVal Parent As Long, _
Optional ByVal Entity As Long, _
Optional ByVal RowType As RowNumbers, _
Optional ByVal Method As Long, _
Optional ByVal Access As Accessibility = -1 _
) As Long
Dim Row As SymRow
Dim Result As SymRow
Dim Rows As KeyedList

Set Rows = Find(Name, Parent, Entity, RowType, Method, Access)

For Each Row In Rows
If Result Is Nothing Then Set Result = Row
If Result.Level > Row.Level Then Set Result = Row
Next

If Not Result Is Nothing Then FindFirst = Result.Id
End Function

Private Function FindDataType(ByVal Name As Long, ByVal Entity As Long, ByVal Access As Accessibility) As Long
Dim Row As SymRow
Dim Result As SymRow
Dim Rows As KeyedList

Set Rows = Find(Name)

For Each Row In Rows
Do
Select Case Row.RowType
Case rnBuiltin, rnClass, rnEnum, rnType
If Access = acPublic And Row.Access <> acPublic Then Exit Do
If Result Is Nothing Then Set Result = Row
If Result.Level > Row.Level Then Set Result = Row
End Select
Loop While False
Next

If Not Result Is Nothing Then FindDataType = Result.Id
End Function

Public Function Find( _
ByVal Name As Long, _
Optional ByVal Parent As Long, _
Optional ByVal Entity As Long, _
Optional ByVal RowType As RowNumbers, _
Optional ByVal Method As Long, _
Optional ByVal Access As Accessibility = -1 _
) As PINQ
Dim Ptr As Long
Dim Row As SymRow
Dim Result As KeyedList

Set Result = New PINQ

For Ptr = 1 To Cap_

Do
With Entries_(Ptr)
If Name <> 0 And .Name <> Name Then Exit Do
If Parent <> 0 And .Parent <> Parent Then Exit Do
If Entity <> 0 And .Entity <> Entity Then Exit Do
If RowType <> 0 And .RowType <> RowType Then Exit Do
If Method <> 0 And .Method <> Method Then Exit Do
If Access <> -1 And .Access <> Access Then Exit Do

Set Row = New SymRow
Row.Id = .Id
Row.Name = .Name
Row.Parent = .Parent
Row.Entity = .Entity
Row.RowType = .RowType
Row.Indirect = .Indirect
Row.Method = .Method
Row.Access = .Access
Row.Flags = .Flags
End With

Result.Add Row
Loop While False
Next

Set Find = Result
End Function

Private Sub IncrementPtr()
Ptr_ = Ptr_ + 1

If Ptr_ > Cap_ Then
Cap_ = Cap_ * 2
ReDim Preserve Entries_(1 To Cap_)
End If
End Sub

Rem Try to find the data type for any pending entry.
Public Sub WrapUp(ByVal Source As SourceFile)
Dim Ptr As Long
Dim Code As Long

For Ptr = 1 To Cap_
Do
Code = 0

With Entries_(Ptr)
Select Case .RowType
Case rnConst, rnVariable, rnFunction, rnPropertyGet, rnDeclareFunction, rnParameter
If .Indirect <> 0 Then Exit Do

Case Else
Exit Do
End Select

If .DataType Is Nothing Then Exit Do
Code = .DataType.Id.Name.Code
.Indirect = FindDataType(Name:=Code, Entity:=.Entity, Access:=.Access)

If .Indirect = 0 Then
Debug.Print "WrapUp: '" & NameBank(.DataType.Id.Name) & "' data type not found"
End If

Set .DataType = Nothing
End With
Loop While False
Next
End Sub

Friend Function MethodID(ByVal Entity As Long, ByVal Method As IMethod) As Long
MethodID = FindFirst( _
Name:=Method.Id.Name.Code, _
Entity:=Entity, _
RowType:=Choose( _
Method.Kind + 1, rnSub, _
rnFunction, _
rnPropertyGet, 0, _
rnPropertyLet, 0, 0, 0, _
rnPropertySet _
), _
Access:=Method.Access _
)
End Function
End Class


Public Class Token
Option Explicit

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

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

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

Public Function IsKeyword(ByVal Code As Long) As Boolean
IsKeyword = Kind = tkKeyword And Me.Code = Code
End Function

Public Function IsOperator(ByVal Code As Long) As Boolean
IsOperator = Kind = tkOperator And Me.Code = Code
End Function

Public Function IsId(ByVal Code As Long, Optional ByVal CanHaveSuffix As Boolean) As Boolean
If Not CanHaveSuffix And Suffix <> vbNullChar Then Exit Function

Select Case Kind
Case tkIdentifier, tkEscapedIdentifier, tkCrazyIdentifier
IsId = Me.Code = Code
End Select
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

Public FileNumber As IExpression
Public RecordRange As IExpression

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


Public Class Variable
Option Explicit
Implements IStmt

Private Subscripts_ As KeyedList

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

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

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snDim
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 + SizeOf(cxObject)
.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 Vocabulary
Option Explicit

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

Public Property Get [AddressOf]() As String
[AddressOf] = "AddressOf"
End Property

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

Public Property Get [And]() As String
[And] = "And"
End Property

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

Public Property Get [Any]() As String
[Any] = "Any"
End Property

Rem Contextual in VB6
Public Property Get [Append]() As String
[Append] = "Append"
End Property

Public Property Get [As]() As String
[As] = "As"
End Property

Public Property Get [Attribute]() As String
[Attribute] = "Attribute"
End Property

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

Rem Contextual in VB6
Public Property Get [Binary]() As String
[Binary] = "Binary"
End Property

Public Property Get [Boolean]() As String
[Boolean] = "Boolean"
End Property

Public Property Get [ByRef]() As String
[ByRef] = "ByRef"
End Property

Public Property Get [Byte]() As String
[Byte] = "Byte"
End Property

Public Property Get [ByVal]() As String
[ByVal] = "ByVal"
End Property

Public Property Get [Call]() As String
[Call] = "Call"
End Property

Public Property Get [Case]() As String
[Case] = "Case"
End Property

Public Property Get [CDecl]() As String
[CDecl] = "CDecl"
End Property

Public Property Get [Circle]() As String
[Circle] = "Circle"
End Property

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

Public Property Get [Close]() As String
[Close] = "Close"
End Property

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

Public Property Get [Const]() As String
[Const] = "Const"
End Property

Rem New!
Public Property Get [Continue]() As String
[Continue] = "Continue"
End Property

Public Property Get [Currency]() As String
[Currency] = "Currency"
End Property

Public Property Get [Date]() As String
[Date] = "Date"
End Property

Public Property Get [Decimal]() As String
[Decimal] = "Decimal"
End Property

Public Property Get [Declare]() As String
[Declare] = "Declare"
End Property

Rem New!
Public Property Get [Default]() As String
[Default] = "Default"
End Property

Public Property Get [DefBool]() As String
[DefBool] = "DefBool"
End Property

Public Property Get [DefByte]() As String
[DefByte] = "DefByte"
End Property

Public Property Get [DefCur]() As String
[DefCur] = "DefCur"
End Property

Public Property Get [DefDate]() As String
[DefDate] = "DefDate"
End Property

Public Property Get [DefDbl]() As String
[DefDbl] = "DefDbl"
End Property

Public Property Get [DefDec]() As String
[DefDec] = "DefDec"
End Property

Public Property Get [DefInt]() As String
[DefInt] = "DefInt"
End Property

Public Property Get [DefLng]() As String
[DefLng] = "DefLng"
End Property

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

Rem New!
Public Property Get [DefLngPtr]() As String
[DefLngPtr] = "DefLngPtr"
End Property

Public Property Get [DefObj]() As String
[DefObj] = "DefObj"
End Property

Public Property Get [DefSng]() As String
[DefSng] = "DefSng"
End Property

Public Property Get [DefStr]() As String
[DefStr] = "DefStr"
End Property

Public Property Get [DefVar]() As String
[DefVar] = "DefVar"
End Property

Public Property Get [Dim]() As String
[Dim] = "Dim"
End Property

Public Property Get [Do]() As String
[Do] = "Do"
End Property

Public Property Get [Double]() As String
[Double] = "Double"
End Property

Public Property Get [Each]() As String
[Each] = "Each"
End Property

Public Property Get [Else]() As String
[Else] = "Else"
End Property

Public Property Get [ElseIf]() As String
[ElseIf] = "ElseIf"
End Property

Public Property Get [Empty]() As String
[Empty] = "Empty"
End Property

Public Property Get [End]() As String
[End] = "End"
End Property

Public Property Get [EndIf]() As String
[EndIf] = "EndIf"
End Property

Public Property Get [Enum]() As String
[Enum] = "Enum"
End Property

Public Property Get [Eqv]() As String
[Eqv] = "Eqv"
End Property

Public Property Get [Erase]() As String
[Erase] = "Erase"
End Property

Rem Contextual in VB6
Public Property Get [Error]() As String
[Error] = "Error"
End Property

Public Property Get [Event]() As String
[Event] = "Event"
End Property

Public Property Get [Exit]() As String
[Exit] = "Exit"
End Property

Rem Contextual in VB6
Public Property Get [Explicit]() As String
[Explicit] = "Explicit"
End Property

Public Property Get [False]() As String
[False] = "False"
End Property

Public Property Get [For]() As String
[For] = "For"
End Property

Public Property Get [Friend]() As String
[Friend] = "Friend"
End Property

Public Property Get [Function]() As String
[Function] = "Function"
End Property

Public Property Get [Get]() As String
[Get] = "Get"
End Property

Public Property Get [Global]() As String
[Global] = "Global"
End Property

Public Property Get [GoSub]() As String
[GoSub] = "GoSub"
End Property

Public Property Get [GoTo]() As String
[GoTo] = "GoTo"
End Property

Public Property Get [If]() As String
[If] = "If"
End Property

Public Property Get [Imp]() As String
[Imp] = "Imp"
End Property

Public Property Get [Implements]() As String
[Implements] = "Implements"
End Property

Public Property Get [In]() As String
[In] = "In"
End Property

Public Property Get [Input]() As String
[Input] = "Input"
End Property

Public Property Get [Integer]() As String
[Integer] = "Integer"
End Property

Public Property Get [Is]() As String
[Is] = "Is"
End Property

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

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

Public Property Get [Len]() As String
[Len] = "Len"
End Property

Public Property Get [Let]() As String
[Let] = "Let"
End Property

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

Public Property Get [Like]() As String
[Like] = "Like"
End Property

Rem Contextual in VB6
Public Property Get [Line]() As String
[Line] = "Line"
End Property

Public Property Get [Local]() As String
[Local] = "Local"
End Property

Public Property Get [Lock]() As String
[Lock] = "Lock"
End Property

Public Property Get [Long]() As String
[Long] = "Long"
End Property

Rem New!
Public Property Get [LongLong]() As String
[LongLong] = "LongLong"
End Property

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

Public Property Get [Loop]() As String
[Loop] = "Loop"
End Property

Public Property Get [LSet]() As String
[LSet] = "LSet"
End Property

Public Property Get [Me]() As String
[Me] = "Me"
End Property

Public Property Get [Mod]() As String
[Mod] = "Mod"
End Property

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

Rem Contextual in VB6
Public Property Get [Name]() As String
[Name] = "Name"
End Property

Public Property Get [New]() As String
[New] = "New"
End Property

Public Property Get [Next]() As String
[Next] = "Next"
End Property

Public Property Get [Not]() As String
[Not] = "Not"