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

Let's build a transpiler! Part 38

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

They don't want you to know

Hey, you. Yes, you! Would like to be around the cool guys and play with pointers?
Whaaa...? No, they're not dangerous. That's what they say so you won't try what they don't want you to try.
Who are they you ask me? You know who they are... Theeey.

Anyways, you want it or not? If you don't, there are many people out there who wants. Don't make me waste my time.
OK, I'll give you some for free. Try VarPtr. With this function, you can get the address of any variable.

Well, not any variable. Most variables. Not array variables. Arrays are trouble makers.
Objects have their own clique, too. You need to use ObjPtr with 'em.

Yeah, yeah, I know VB's help don't mention any of 'em. They don't want you to know, remember? But they are there. Hidden in plain sight.
When you're good with VarPtr and ObjPtr, you can start with StrPtr. It don't give you the address of the variable, but the address that the address is pointing to. How cool is that, amirite?

What do you mean by "What if all I have is an array variable?"
Then you'd Declare a... Whoa... Is that an AddressOf there I'm seein'?.
Know what? I'm outta here, man. You're bananas!

Back to business

Last time I said we'll start cleaning up some pending items before starting to transpile for real.
Coming from the last post, I've changed not only Messages from module to class but also Vocabulary from module to class.
I gave a little love to Messages too, removing duplicates and giving each message a real name, not that Msg001 thing.
Apart from that, I removed passing Entity as an argument where it was not needed, but then I created a ControlPanel class.

This class will be used to check if some statements are legal. For instance, if we parse a Continue Do, we need to be sure we are inside a Do/Loop.
So, whenever we parse a Do, we'll increment a counter in (Control)Panel. When parsing a Continue Do, we check that counter. If it is zero, we have an illegal statement.
We'll do the same to Continue While/For, Exit Do/For/While, and something similar to Exit Sub/Function/Property.

I was also planning to use Panel to match GoTo/GoSub targets with actual line numbers and labels, but it did not work as expected. I need to improve it a bit before disclosing it.

Another code I worked on was in classifying number literals.
I suspect we'll have to know every variable and literal types in fine detail to succeed in transpiling VB code. So I started with literal numbers.
VB has an inconsistency related to that: -32768 hexadecimal representation is &H8000, but if you try the snippet below, you'll get False as an answer:

Debug.Print TypeName(-32768) = TypeName(&H8000)
&H8000's type is Integer, but -32768 is Long even though -32768 is within Integer's value range. Why is that?
I suppose that's because VB parses the minus operator and then the number - just like we are doing. Positive 32768 is not a valid Integer number - it is a Long one.
The same goes for &H80000000 and -2147483648. The former is Long, the latter is Double.
I don't want to perpetuate it, so here is my plan:

When parsing an integer literal, append a plus sign ("+") to its left.
Classify it as an Integer, Long, or LongLong.
Find a spot in code where we have an unambiguous negation sign (not a subtraction one) and check if it is being applied to an integer literal.
If it is, then merge the sign with the literal by changing that plus sign by a minus one.
If that plus sign has already been changed to a minus one, then restore the plus sign.
After merging the sign, reclassify it if needed. That's when we'll get an Integer out of that Long -32768.

The better place I could find to do that was in the Move method. Take a look there. Token's Code property will have a double duty: For identifiers, it will be their index into NameBank. For integers, it will be their classification.

Another thing I should mention is that downgrading keywords in NextToken is not enough. My tests showed that sometimes it was too late. I had to downgrade them in GetExpression too.
There was one keyword that proved hard to be "diminished", though: Rem. Our parser does not handle "v.Rem" well. It thinks Rem is a keyword and thus "eats" everything after it as it was comment's text. We cannot have v.Rem; it must be v.[Rem] instead. (This is in line with .NET, and I wonder if it is for the same reason.)

Finally, I will dump the whole code again, but with a twist: This is not valid VB6 code. It is using some new features like Continue and compound operators (i.e. "&=").
I did it to be able to test the parsing code feeding it with its own code. Due to that, I fixed a lot of bugs, and not all of them were retro-fixed.

Next week we'll go on risking things from our pending list.

Andrej Biasic
2021-06-09

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

Public BodyType As Long
Public DoCount As Long
Public ForCount As Long
Public WhileCount As Long
Public SelectCount As Long
Public Entity As Entity
End Class

Public Class DataType
Option Explicit

Public Id As Identifier
Public IsArray As Boolean
Public FixedLength As IExpression
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
Debug.Assert IKLValidator_Validate
End Function
End Class

Public Class DefType
Option Explicit
Const LAST_INDEX = 25

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

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

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

Dim Index As Integer = ToIndex(Letter)

If A_Z_ Then
Set Item = Letters_(0)

ElseIf Index = -1 OrElse 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 = ToIndex(FirstLetter)
Dim Last As Integer = ToIndex(LastLetter)

If First > Last Then
Dim Letter As Integer = First
First = Last
Last = Letter
End If

A_Z_ = First = 0 AndAlso Last = LAST_INDEX

Dim Token As Token
Set Token = New Token
Token.Kind = tkKeyword

Select Case VariableType
Case vbBoolean
Token.Code = kwBoolean

Case vbByte
Token.Code = kwByte

Case vbInteger
Token.Code = kwInteger

Case vbLong
Token.Code = kwLong

Case vbLongLong
Token.Code = kwLongLong

Case vbLongPtr
Token.Code = kwLongPtr

Case vbCurrency
Token.Code = kwCurrency

Case vbDecimal
Token.Code = cxDecimal

Case vbSingle
Token.Code = kwSingle

Case vbDouble
Token.Code = kwDouble

Case vbDate
Token.Code = kwDate

Case vbString
Token.Code = kwString

Case vbObject
Token.Code = cxObject

Case vbVariant
Token.Code = kwVariant

Case Else
Debug.Assert False
End Select

For Letter = First To Last
If Letters_(Letter) IsNot Nothing AndAlso Letters_(Letter).Text <> Token.Text Then Err.Raise 0
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 = AscW(Left$(Letter, 1))
If Result >= SMALL_A Then Result += CAPITAL_A - SMALL_A
If Result < CAPITAL_A OrElse Result > CAPITAL_Z Then Result = CAPITAL_A - 1
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 Accessibility As Accessibility
Public Id As Identifier

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

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

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

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

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

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

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

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

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

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

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 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 = 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 Cp As Integer
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
Dim WantOperand As Boolean = True

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

If WantOperand Then
WantOperand = False

Select Case Token.Kind
Case tkOperator
WantOperand = True

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

If Token.Kind <> tkOperator Then
Set Token = Nothing
Continue Do
End If

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

Case opSubt
Token.Code = opNeg

Rem Unary operators
Case opAddressOf, opNew, opNot, opTypeOf, opWithBang, opWithDot
Exit Select

Case Else
Exit Do
End Select

Set Op = NewOperator(Token)
OpStack.Add Op

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

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

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

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

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

Case 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:
Rem Unary and compound operators
Select Case Token.Code
Case opAddressOf, opNew, opNot, opTypeOf
Parser.Fail Token, x.InvExpr

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

Set Op2 = NewOperator(Token)

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

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

OpStack.Add 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 Not CanHaveTo OrElse HadTo Then Err.Raise vbObjectError + 13
HadTo = True

Token.Kind = tkOperator
Token.Code = NameBank.Operators.IndexOf(V.To)
OpStack.Add NewOperator(Token)
WantOperand = True

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 OrElse OutStack.Count = 1 AndAlso OpStack.Count > 0
Set Op = Peek(OpStack)
If Op.Value.Kind = tkLeftParenthesis Then Exit Do

Move OpStack, OutStack, Op
Loop

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

CheckDowngrade:
If Op Is Nothing Then Return
If Op.IsUnary Or Op.Value.Code <> opDot And Op.Value.Code <> opBang Then Return
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 AndAlso 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.Code
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 OrElse Token.Code = opWithDot Then
Set Uni = New UnaryExpression
Set Uni.Operator = NewOperator(Token)
Set Token = Parser.NextToken
If Token.Kind <> tkIdentifier AndAlso 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 AndAlso Token.Kind <> tkEscapedIdentifier 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
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 Token IsNot Nothing AndAlso 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

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

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
End Select
End If

Args.Add Expr

If Token.Kind = tkRightParenthesis OrElse _
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 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_ -= 1
End Sub

Private Sub ITextBuilder_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

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
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 Name_ IsNot Nothing Then Set Project_ = Name_
Set Name_ = Value
End Property

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

Public Class IExpression
Option Explicit

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

Private Sub Class_Initialize()
Err.Raise 5
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
End Sub

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

Public Class ImplementsConstruct
Option Explicit

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

Set Id = Hidden
End Property
End Class

Public Class InputConstruct
Option Explicit
Implements IStmt

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

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

Private Sub Class_Initialize()
Err.Raise 5
End Sub

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

Public Class ITextBuilder
Option Explicit

Private Sub Class_Initialize()
Err.Raise 5
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 KeyedList
Option Explicit
Private ReadOnly_ As Boolean
Private Base_ As Integer
Private ID_ As Long
Private Count_ As Long
Private Root_ As KLNode
Private Last_ As KLNode
Private Validator_ As IKLValidator
Private CompareMode_ As VbCompareMethod

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

Private Sub Class_Terminate()
ReadOnly_ = False
Clear
End Sub

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

Public Sub Add(ByVal Item As Variant, Optional ByVal Key As Variant)
Const Id = "72E0DEDF0CD34921A650C8DD99F21A68_"

Dim NewKey As String
Dim NewNode As KLNode

If ReadOnly_ Then Err.Raise 5
If Validator_ IsNot Nothing AndAlso 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_ += 1

Case Else
Err.Raise 13
End Select

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

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

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

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

Count_ += 1
End Sub

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

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

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

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

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

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

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

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

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

If ReadOnly_ Then Err.Raise 5
Set CurNode = Root_

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

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

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

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

ElseIf PrvNode IsNot Nothing Then
Set PrvNode.NextNode = CurNode.NextNode
End If

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

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

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

Public Iterator Function NewEnum() As IUnknown
Dim It As KLEnumerator

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

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

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

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

Count_ = 0
End Sub

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

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

If Idx >= 0 Then
Set Node = Root_

Do Until Node Is Nothing OrElse Idx = 0
Set Node = Node.NextNode
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 += 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 = UBound(KeyValuePairs)
If Udx Mod 2 = 0 Then Err.Raise 5

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

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

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

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

Public Class KLEnumerator
Option Explicit

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

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

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

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

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

If IsObject(List_(Index_)) Then Set Items = List_(Index_) Else Items = List_(Index_)
Index_ += 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_ += 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 NoNew() As String
NoNew = "Invalid use of New"
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
End Class

Public Class NameBank
Option Explicit

Private Ids_ As KeyedList
Private Keywords_ As KeyedList
Private Operators_ As KeyedList
Private Contextuals_ 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.Debug, 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
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 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, opId, opNeg, opWithDot, opWithBang, opByVal
IsUnary = True
End Select
End Property

Public Property Get IsBinary() As Boolean
IsBinary = Not IsUnary
End Property
End Class

Public Class Parameter
Option Explicit

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

Public Class Parser
Option Explicit
Option Compare Binary

Public Enum Accessibility
acLocal
acPublic
acPrivate
acFriend
End Enum

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

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

Private Type AccessToken
Access As Accessibility
Token As Token
End Type

Private Downgrade_ As Boolean
Private WasAs_ As Boolean
Private LastToken_ As Token
Private LookAhead_ As Token
Private Scanner_ As Scanner
Private Source_ As SourceFile
Private 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
Else
Set Token = LookAhead_
Set LookAhead_ = Nothing
End If

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

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

Case tkKeyword
If Downgrade_ Then
Downgrade_ = False
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
Downgrade_ = False
WasAs_ = False

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

Case cxName, cxReset
Upgrade = LastToken_.Kind <> tkKeyword OrElse 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 OrElse 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 += 1

Case tkSoftLineBreak, tkHardLineBreak
WasAs_ = False
End Select

If Upgrade Then
If Token.Suffix <> vbNullChar Then Fail Token, x.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

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

If Token.Kind <> tkHardLineBreak AndAlso 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.Accessibility = acPublic
Set Token = NextToken

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

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

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

ElseIf Entity.Accessibility = acLocal Then
Fail Token, x.RuleEntityHeader, x.PublicEtc

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

Set Mark = Token

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

Set Entity.Id = NewId(Token)
MustEatLineBreak

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

If Not Token.IsKeyword(kwEnd) Then
Set Token = ParseProcedureArea(Entity, AccessToken)
If Not Token.IsKeyword(kwEnd) Then Fail Token, x.RuleEndEntity, V.End
End If

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

Name = NameBank(Entity.Id.Name)
If Source_.Entities.Exists(Name) Then Fail Entity.Id.Name, x.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 HadCompare As Boolean
Dim KeepToken As Boolean
Dim Text As String
Dim Token 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, x.RuleIdHeader, x.IdName
Set Token = ParseAttributes(Entity.Attributes, Token)
KeepToken = True

Case kwOption
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail Token, x.RuleOption, x.ExpBaseEtc

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

Set Token = NextToken

If Token.Kind <> tkIntegerNumber OrElse (Token.Text <> "+0" AndAlso Token.Text <> "+1") Then
Fail Token, x.RuleOptionBase, x.ZeroOne
End If

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

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

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

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

Case cxText
Entity.OptionCompare = vbTextCompare

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

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

Case Else
Fail Token, x.RuleOption, V.Option
End Select

Case kwDefBool
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbBoolean, Entity

Case kwDefByte
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbByte, Entity

Case kwDefInt
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbInteger, Entity

Case kwDefLng
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbLong, Entity

Case kwDefLngLng
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbLongLong, Entity

Case kwDefLngPtr
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbLongPtr, Entity

Case kwDefCur
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbCurrency, Entity

Case kwDefDec
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbDecimal, Entity

Case kwDefSng
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbSingle, Entity

Case kwDefDbl
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbDouble, Entity

Case kwDefDate
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbDate, Entity

Case kwDefStr
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbString, Entity

Case kwDefObj
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbObject, Entity

Case kwDefVar
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbVariant, Entity

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

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

Case kwConst
If Access = acLocal Then Access = acPrivate
ParseConsts Access, Panel, Entity.Consts
Access = acLocal

Case kwEnum
ParseEnum Access, Panel
Access = acLocal

Case kwDeclare
ParseDeclare Access, Panel
Access = acLocal

Case kwEvent
If Not Entity.IsClass Then Fail Token, x.ValidInClass
If Access = acLocal Then Access = acPublic
If Access <> acPublic Then Fail Token, x.EventIsPublic
ParseEvent Panel
Access = acLocal

Case kwImplements
If Not Entity.IsClass Then Fail Token, x.ValidInClass
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseImplements Entity

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

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

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

Case kwFriend
If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
If Not Entity.IsClass Then Fail Token, x.ValidInClass
Access = acFriend
Exit Do

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

Case Else
Fail Token, x.ExpOptEtc
End Select

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

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

Else
Fail Token, x.ExpOptEtc
End If
Loop

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

Private Function ParseProcedureArea(ByVal Entity As Entity, ByRef AccessToken As AccessToken) As Token
Dim IsDefault As Boolean
Dim HadDefault As Boolean
Dim IsIterator As Boolean
Dim HadIterator As Boolean
Dim IsStatic As Boolean
Dim Token As Token
Dim Proc As SubConstruct
Dim Panel As ControlPanel
Dim Func As FunctionConstruct
Dim Prop As PropertyConstruct

Dim Access As Accessibility = AccessToken.Access
Set Token = AccessToken.Token

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

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

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

Case kwDefault
If IsDefault OrElse HadDefault Then Fail Token, x.DuplDefault
HadDefault = True
IsDefault = True

Case kwIterator
If IsIterator OrElse HadIterator Then Fail Token, x.DuplIterator
HadIterator = True
IsIterator = True

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

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

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

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

Set Func = ParseFunction(Access, Panel)
Func.IsDefault = IsDefault
Func.IsStatic = IsStatic
Func.IsIterator = IsIterator
If Func.IsDefault AndAlso Func.IsIterator Then Fail Token, x.NoDefaultIt
GoSub Cleanup

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

Set Prop = ParseProperty(Access, Panel)
Prop.IsDefault = IsDefault
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)
Dim First As String
Dim Last As String
Dim Token As Token
Dim Mark As Token

Do
Set Token = SkipLineBreaks
Set Mark = Token

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

First = NameBank(Token)
Set Token = NextToken

If Token.IsOperator(opSubt) Then
Set Token = NextToken
If Token.Kind <> tkIdentifier OrElse Token.Suffix <> vbNullChar Then Fail Token, x.RuleDefType, x.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, x.DuplDefType
End If

On Error GoTo 0

If IsBreak(Token) Then Exit Do
If Token.Kind <> tkListSeparator Then Fail Token, x.RuleDefType, x.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
If Not IsProperId(Token) Then Fail Token, x.RuleConst, x.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, x.IdHasSygil

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

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

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

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

Rem Get Const's value
Set Cnt.Value = Xp.GetExpression(Me)
If Cnt.Value Is Nothing Then Fail Token, x.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, x.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

Rem Move on
Set Token = Xp.LastToken

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

If Token.Kind <> tkListSeparator Then Fail Token, x.RuleConst, x.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
If Not IsProperId(Token) Then Fail Token, x.RuleEnum, x.IdName
If Token.Suffix <> vbNullChar Then Fail Token, x.EnumSygil

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

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

Do
Set Token = SkipLineBreaks
If Token.IsKeyword(kwEnd) Then Exit Do
If Not IsProperId(Token) Then Fail Token, x.RuleAssign, x.IdName
If Token.Suffix <> vbNullChar Then Fail Token, x.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, x.InvExpr
End If

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

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

If Not Token.IsKeyword(kwEnd) Then Fail Token, x.RuleEndEnum, V.End

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

If Enm.Enumerands.Count = 0 Then Fail Enm, x.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, x.RuleDeclareHeader, x.SubFunc
End If

Rem Get its name.
Set Token = NextToken
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, x.RuleDeclareHeader, x.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, x.RuleDeclareHeader, V.Lib

Rem Get Lib's name
Set Token = NextToken
If Token.Kind <> tkString Then Fail Token, x.RuleDeclareHeader, x.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, x.RuleDeclareHeader, x.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, x.ExpEOS
If Token.Suffix <> vbNullChar Then Fail Token, x.IdHasSygil

Rem Get data type name
Set Token = NextToken

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

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

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

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

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

Rem Maybe it returns an array?
If Token.Kind = tkLeftParenthesis Then
Set Token = NextToken
If Token.Kind <> tkRightParenthesis Then Fail Token, x.ParensMismatch
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
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 += 1
If Index >= 60 Then Fail Token, x.TooManyParms

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

ElseIf Token.IsKeyword(kwParamArray) Then
If LastParm.IsOptional Then Fail Token, x.OptParamArray
If SignatureKind = skEvent OrElse SignatureKind = skTuple Then Fail Token, x.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, x.NoByval
CurrParm.IsByVal = True
Set Token = NextToken

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

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

Set Token = NextToken

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

If CurrParm.IsParamArray AndAlso Not CurrParm.IsArray Then Fail CurrParm.Id, x.ParamIsArray

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

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

Set CurrParm.DataType.Id.Name = Token

If CurrParm.IsParamArray AndAlso ( _
CurrParm.DataType.Id.Project IsNot Nothing OrElse _
CurrParm.DataType.Id.Name.Code <> kwVariant) Then _
Fail Token, x.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, x.NonOptional
If CurrParm.IsParamArray Then Fail Token, x.NoParamDefault
Set CurrParm.Init = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If CurrParm.Init Is Nothing Then Fail Token, x.InvExpr
End If

If Not CurrParm.IsOptional AndAlso (LastParm.IsOptional Or LastParm.IsParamArray) Then
If SignatureKind <> skPropertyLet AndAlso SignatureKind <> skPropertySet Then _
Fail CurrParm.Id, x.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 OrElse SignatureKind = skPropertySet Then
If Parms.Count = 0 Then
Fail Token, x.ArgReqProp

ElseIf LastParm.IsOptional OrElse LastParm.IsParamArray Then
Fail LastParm.Id, x.ArgReqProp
End If
End If

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

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

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

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

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

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

Set Token = SkipLineBreaks
If Not IsProperId(Token) Then Fail Token, x.RuleEvent, x.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, x.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 Token As Token
Dim Impls As ImplementsConstruct

Set Token = SkipLineBreaks
If Token.Kind <> tkIdentifier Then Fail Token, x.RuleImplements, x.PrjOrId
If Token.Suffix <> vbNullChar Then Fail Token, x.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, x.RuleImplements, x.IdName
If Token.Suffix <> vbNullChar Then Fail Token, x.NoSygil

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

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

Private Function ParseSub(ByVal Access As Accessibility, ByVal Panel As ControlPanel) As SubConstruct
Dim Token As Token
Dim Proc As SubConstruct

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

Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, x.RuleSubHeader, x.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, x.ExpEOS
End If

Set Token = ParseAttributes(Proc.Attributes)
Set Token = ParseBody(Panel, Proc.Body, LookAhead:=Token)
If Not Token.IsKeyword(kwSub) Then Fail Token, x.RuleEndSub, V.Sub
MustEatLineBreak

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

Set ParseSub = Proc
End Function

Private Function ParseFunction(ByVal Access As Accessibility, ByVal Panel As ControlPanel) As FunctionConstruct
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

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

Set Func.Id = NewId(Token)
Dim Name As String = 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, x.ExpEOS
End If

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

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

Set Token = NextToken

If Token.IsOperator(opDot) Then
Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, x.AsPrjId, x.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, x.ParensMismatch
Func.DataType.IsArray = True
End If

If Not IsBreak(Token) Then MustEatLineBreak
Set Token = ParseAttributes(Func.Attributes)
Set Token = ParseBody(Panel, Func.Body, LookAhead:=Token)
If Not Token.IsKeyword(kwFunction) Then Fail Token, x.RuleEndFunc, V.Function
MustEatLineBreak

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

Set ParseFunction = Func
End Function

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

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

Set Token = NextToken

If Token.Kind <> tkKeyword Then Fail Token, x.ExpGLSet

Select Case Token.Code
Case kwGet
Kind = VbGet

Case kwLet
Kind = VbLet

Case kwSet
Kind = VbSet

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

Set Token = NextToken
If Not IsProperId(Token, CanHaveSuffix:=Kind = VbGet) Then Fail Token, x.RulePropHeader, x.IdName

Set PropToken = Token
Dim Name As String = NameBank(Token)

CheckDupl Panel.Entity, Token, JumpProp:=True

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

Set Token = NextToken

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

ElseIf Not IsBreak(Token) Then
Fail Token, x.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, x.Duplicated
Next

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

Set Token = NextToken

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

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

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

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

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

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

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

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

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

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

Slot.Add Kind, Prop

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

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

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

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

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

For Idx = 1 To LeftParms.Count - 1
If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail Slot.Id.Name, x.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
If Not IsProperId(Token) Then Fail Token, x.RuleAttribute, x.ExpVarId
Set Attr.Id = NewId(Token)

Set Token = NextToken

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

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

If Not Token.IsOperator(opEq) Then Fail Token, x.ExpVarId, x.ExpEq
Set Attr.Value = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Attr.Value Is Nothing Then Fail Token, x.ExpVarId, x.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 _
)
Dim WasArray As Boolean
Dim Var As Variable
Dim Expr As IExpression
Dim Subs As SubscriptPair
Dim Xp As Expressionist
Dim Bin As BinaryExpression

If InsideProc AndAlso (Access = acPublic OrElse Access = acPrivate) Then Fail Token, x.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

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

Var.HasWithEvents = True
Set Token = NextToken
End If

If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, x.RuleDim, x.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
Fail Token, x.InvExpr
End Select

Var.Subscripts.Add Subs
End If

If Token.Kind <> tkListSeparator Then Exit Do
Loop

If Token.Kind <> tkRightParenthesis AndAlso Xp.LastToken.Kind <> tkRightParenthesis Then _
Fail Token, x.ParensMismatch

WasArray = True
Set Token = NextToken
End If

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

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

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

If Var.HasNew AndAlso Var.DataType.Id.Name.Kind = tkKeyword Then Fail Token, x.NoNew

Set Token = NextToken

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

If Not IsProperDataType(Token) Then Fail Token, x.RuleDim, x.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, x.InvExpr
End If

Var.DataType.IsArray = WasArray
If Var.HasNew AndAlso Var.DataType.IsArray Then Fail Token, x.NoNew

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

Dim Name As String = NameBank(Var.Id.Name)
If Not InsideProc Then CheckDupl Panel.Entity, Var.Id.Name
If Vars.Exists(Name) Then Fail Token, x.AmbiguousName & Name
Vars.Add Var, Name
Panel.AddVar Var

If IsBreak(Token) Then Exit Do
If Token.Kind <> tkListSeparator Then Fail Token, x.RuleDim, x.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
If Not IsProperId(Token) Then Fail Token, x.RuleType, x.IdName

Set Typ.Id = NewId(Token)
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, x.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, x.RuleTypeMember, V.As

Rem Must not have an initial value
If Var.Init IsNot Nothing Then Fail Var.Init, x.ExpEOS

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

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

Set Token = NextToken
If Not Token.IsKeyword(kwType) Then Fail Token, x.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
Set Token = NextToken
End If

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

If LookAhead.Kind = tkSoftLineBreak Then
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Body.Add 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, x.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 kwDebug
Rem HACK:
GoTo Up

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, x.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, x.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, x.ExpEqArg
Body.Add Stmt
End Select

Case tkEscapedIdentifier
GoTo Up

Case tkDirective
Do
Set Token = NextToken
Loop Until IsBreak(Token)

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

Case Else
Debug.Assert False
End Select

Case tkHardLineBreak
Exit Select

Case Else
Fail Token, x.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 OrElse Token.Code = opWithDot

Case tkIdentifier, tkEscapedIdentifier, 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, x.ExpDoEtc

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

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

Case kwWhile
If Panel.WhileCount = 0 Then Fail Token, x.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, x.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, x.InvExpr
End If

If Not IsBreak(Token) Then Fail Token, x.ExpEOS
Panel.DoCount += 1
Set Token = ParseBody(Panel, Stmt.Body)
Panel.DoCount -= 1
If Not Token.IsKeyword(kwLoop) Then Fail Token, x.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, x.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, x.InvExpr
End If
End If

If Not IsBreak(Token) Then Fail Token, x.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
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, x.RuleErase, x.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, x.ExitNonDo
Stmt.What = ewDo

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

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

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

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

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

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

Else
Fail Token, x.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
If Not IsProperId(Token) Then Fail Token, x.RuleFor, x.IdName

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

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

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

If Expr Is Nothing Then Fail Mark, x.InvExpr
If Expr.Kind <> ekBinaryExpr Then Fail Mark, x.InvExpr
Set Bin = Expr
If Not Bin.Operator.Value.Code = opTo Then Fail Token, x.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, x.RuleFor, x.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, x.ExpEOS
Panel.ForCount += 1
Set Token = ParseBody(Panel, Stmt.Body)
Panel.ForCount -= 1
If Not Token.IsKeyword(kwNext) Then Fail Token, x.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, x.ExpEOS
End If

ElseIf IsBreak(Token) Then
Rem OK

Else
Fail Token, x.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
If Not IsProperId(Token) Then Fail Token, x.RuleForEach, x.VariableName

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

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

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

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

Panel.ForCount += 1
Set Token = ParseBody(Panel, Stmt.Body)
Panel.ForCount -= 1
If Not Token.IsKeyword(kwNext) Then Fail Token, x.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, x.RuleGet, x.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Token, x.RuleGet, x.Comma

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

Set Token = NextToken
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, x.RuleGet, x.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

If IsProperId(Token) Then
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)

Set Stmt.Target = Label

ElseIf Token.Kind = tkIntegerNumber AndAlso Left$(Token.Text, 1) <> "-" Then
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token

Set Stmt.Target = LinNum
Else
Fail Token, x.ExpTarget
End If

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
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Set Stmt.Target = Label

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

Set Stmt.Target = LinNum

Case Else
Fail Token, x.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, x.InvExpr

Rem If <condition> Then ?
If Not Token.IsKeyword(kwThen) Then Fail Token, x.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, x.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, x.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, x.ExpEOS

ElseIf IsHardBreak(Token) Then
Set Token = ParseBody(Panel, Arm.Body)
If Token.Kind <> tkKeyword Then Fail Token, x.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, x.InvExpr

Set Token = Xp.LastToken
If Not Token.IsKeyword(kwThen) Then Fail Token, x.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, x.ExpEOS

Set Token = ParseBody(Panel, Stmt.ElseBody)

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

Fail Token, x.ExpEnd & V.If

Case kwIf
Set Token = NextToken
Exit Do

Case Else
Fail Token, x.ExpElseEtc
End Select
Loop

ElseIf IsStatement(Token) Then
GoTo Up

Else
Fail Token, x.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, x.RuleInput, x.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Token, x.RuleInput, x.Comma

Do
Set Token = NextToken
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, x.RuleInput, x.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, x.RuleLock, x.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, x.RuleLock, x.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, x.RuleLSet, x.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, x.RuleName, x.OldPathName
If Not Xp.LastToken.IsKeyword(kwAs) Then Fail Xp.LastToken, x.RuleName, V.As

Set Stmt.NewPathName = Xp.GetExpression(Me)
If Stmt.NewPathName Is Nothing Then Fail Xp.LastToken, x.RuleName, x.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, x.ExpTarget
Set WentTo = New GoToConstruct
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token
Set WentTo.Target = LinNum
Set OnStmt.Statement = WentTo

Case tkIdentifier
Set WentTo = New GoToConstruct
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Set WentTo.Target = Label
Set OnStmt.Statement = WentTo

Case Else
Fail Token, x.ExpTarget
End Select

ElseIf Token.IsKeyword(kwResume) Then
Set Token = NextToken
If Not Token.IsKeyword(kwNext) Then Fail Token, x.ExpNext

Set ResStmt = New ResumeConstruct
ResStmt.IsNext = True
Set OnStmt.Statement = ResStmt

Else
Fail Token, x.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, x.InvExpr

If Token.IsKeyword(kwGoTo) Then
Comp.IsGoTo = True

ElseIf Token.IsKeyword(kwGoSub) Then
'Comp.IsGoTo = False

Else
Fail Token, x.ExpGoToSub
End If

Do
Set Token = NextToken

Select Case Token.Kind
Case tkIntegerNumber
If Left$(Token.Text, 1) = "-" Then Fail Token, x.ExpTarget
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token
Comp.Targets.Add LinNum

Case tkIdentifier
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Comp.Targets.Add Label

Case Else
Fail Token, x.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, x.RuleOpen, x.PathName
If Not Xp.LastToken.IsKeyword(kwFor) Then Fail Xp.LastToken, x.RuleOpen, V.For

Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail Token, x.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, x.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, x.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, x.RuleOpen, V.As
Set Stmt.FileNumber = Xp.GetExpression(Me)
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, x.RuleOpen, x.HashFileNumber
Set Token = Xp.LastToken

If Token.IsKeyword(cxLen) Then
Set Token = NextToken
If Not Token.IsOperator(opEq) Then Fail Token, x.RuleOpen, x.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, x.RulePrint, x.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Token, x.RulePrint, x.Comma
Set Token = Nothing

Do
Set Expr = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken
If Expr Is Nothing Then Fail Xp.LastToken, x.RulePrint, x.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, x.RulePut, x.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, x.RulePut, x.Comma

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

Set Token = NextToken
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, x.RulePut, x.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, x.NoNew
If Var.Init IsNot Nothing Then Stop 'TODO: Remove Stop
If Var.Subscripts.Count = 0 Then Fail Var.Id.Name, x.ExpSubscript
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, x.InvLinNum
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token
Set Stmt.Target = LinNum
Set Token = NextToken

Case tkIdentifier
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Set Stmt.Target = Label
Set Token = NextToken

Case tkKeyword
If Token.Code <> kwNext Then Fail Token, x.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, x.RuleSelect, V.Case

Set Stmt.Value = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.Value Is Nothing Then Fail Token, x.InvExpr
If Not IsBreak(Token) Then Fail Token, x.ExpEOS
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, x.ExpEnd & V.Select
End If

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
'IsExpr.LHS will be Nothing

Set Token = NextToken
If Token.Kind <> tkOperator Then Fail Token, x.ExpCompOp

Set IsExpr.Operator = NewOperator(Token)
If IsExpr.Operator.IsUnary Then Fail Token, x.ExpCompOp

Set IsExpr.RHS = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If IsExpr.RHS Is Nothing Then Fail Token, x.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, x.ExpEnd & V.Select

Rem Cs must not be added after Loop
Set Cs = Nothing
Exit Do

Else
Fail Token, x.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, x.CommaOrEOS
Loop

If Cs IsNot Nothing Then Stmt.Cases.Add Cs
Loop Until Token.IsKeyword(kwSelect)

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, x.RuleRSet, x.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, x.RuleSeek, x.HashFileNumber
If Xp.LastToken.Kind <> tkListSeparator Then Fail Xp.LastToken, x.RuleSeek, x.Comma

Set Stmt.Position = Xp.GetExpression(Me)
If Stmt.Position Is Nothing Then Fail Xp.LastToken, x.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, x.RuleUnlock, x.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, x.RuleUnlock, x.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, x.InvExpr

If Not IsBreak(Token) Then Fail Token, x.ExpEOS
Panel.WhileCount += 1
Set Token = ParseBody(Panel, Stmt.Body)
Panel.WhileCount -= 1

If Token.IsKeyword(kwWend) Then
Rem OK

ElseIf Token.IsKeyword(kwWhile) Then
Rem OK

Else
Fail Token, x.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, x.RuleWidth, x.HashFileNumber
If Xp.LastToken.Kind <> tkListSeparator Then Fail Xp.LastToken, x.RuleWidth, x.Comma

Xp.CanHaveTo = True
Set Stmt.Value = Xp.GetExpression(Me)
If Stmt.Value Is Nothing Then Fail Xp.LastToken, x.RuleWidth, x.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
If Not IsProperId(Token) Then Fail Token, x.RuleWith, x.ObjectName

Set Stmt.PinObject = Xp.GetStmt(Me, Token)
Set Token = Xp.LastToken
If Stmt.PinObject Is Nothing Then Fail Token, x.RuleWith, x.ObjectName

Set Token = ParseBody(Panel, Stmt.Body, LookAhead:=Token)
If Not Token.IsKeyword(kwWith) Then Fail Token, x.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, x.RuleWrite, x.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, x.RuleWrite, x.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
AreEqual = LeftParm.IsArray = RightParm.IsArray AndAlso _
LeftParm.IsByVal = RightParm.IsByVal AndAlso _
LeftParm.IsOptional = RightParm.IsOptional AndAlso _
LeftParm.IsParamArray = RightParm.IsParamArray AndAlso _
LeftParm.DataType.Id.Name.Code = RightParm.DataType.Id.Name.Code
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) OrElse Token.Kind = tkComment Then Exit Sub
Fail Token, x.ExpEOS
End Sub

Private Function SkipLineBreaks() As Token
Dim Token As Token

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

Set SkipLineBreaks = Token
End Function

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

Dim Pos As Integer
Dim Cp As Integer

If Not CanHaveSuffix AndAlso Token.Suffix <> vbNullChar Then Fail Token, x.NoSygil

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

If Token.Kind <> tkEscapedIdentifier Then Exit Function
Dim Text As String = NameBank(Token)

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

IsProperId = True
End Function

Friend Function IsHardBreak(ByVal Token As Token) As Boolean
IsHardBreak = Token.Kind = tkHardLineBreak OrElse 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, x.NoSygil

Select Case Token.Kind
Case tkIdentifier
IsProperDataType = True

Case tkEscapedIdentifier
IsProperDataType = IsProperId(Token)

Case tkKeyword
IsProperDataType = IsBuiltinDataType(Token)
End Select
End Function

Private Function IsConstDataType(ByVal Token As Token) As Boolean
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, x.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) OrElse _
Token.Kind = tkRightParenthesis OrElse _
Token.Kind = tkListSeparator OrElse _
Token.Kind = tkPrintSeparator

If Not Result AndAlso Token.Kind = tkKeyword Then
Result = Token.Code = kwThen OrElse 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 Got As String

Select Case Token.Kind
Case tkEscapedIdentifier
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 &= Token.Suffix
Dim Text As String = NameBank(Token)

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

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

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

Set Token = New Token
Token.Kind = tkKeyword

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

Case "&"
Token.Code = kwLong

Case "^"
Token.Code = kwLongLong

Case "@"
Token.Code = kwCurrency

Case "!"
Token.Code = kwSingle

Case "#"
Token.Code = kwDouble

Case "$"
Token.Code = kwString

Case Else
Debug.Assert False
End Select

Set FromChar = NewDataType(Token)
End Function

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

With Entity
If .Consts.Exists(Name) OrElse _
.Enums.Exists(Name) OrElse _
.Declares.Exists(Name) OrElse _
.Events.Exists(Name) OrElse _
.Impls.Exists(Name) OrElse _
.Vars.Exists(Name) OrElse _
.Types.Exists(Name) OrElse _
.Subs.Exists(Name) OrElse _
.Functions.Exists(Name) OrElse _
Not JumpProp AndAlso .Properties.Exists(Name) Then _
Fail Token, x.AmbiguousName & Name
End With
End Sub
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

Private Parms_ As KeyedList
Private Body_ As KeyedList
Private Attributes_ As KeyedList

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

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

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

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

Public Class PropertySlot
Option Explicit

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

Public Id As Identifier
Public DataType As DataType

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

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

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

Case Else
Debug.Assert False
End Select
End Sub

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

Case VbLet
Set Item = PropertyLet_

Case VbSet
Set Item = PropertySet_

Case Else
Debug.Assert False
End Select
End Property

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

Case VbLet
Exists = Not PropertyLet_ Is Nothing

Case VbSet
Exists = Not PropertySet_ Is Nothing

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

Public Class PutConstruct
Option Explicit
Implements IStmt

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

Public Builder As ITextBuilder

Public Sub Transpile(ByVal Source As SourceFile)
Dim Idx As Integer

For Idx = 1 To Source.Entities.Count
EmitEntity Source.Entities(Idx)
If Idx <> Source.Entities.Count Then Builder.AppendLn
Next
End Sub

Private Sub EmitEntity(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
EmitAccess Entity.Accessibility
.Append IIf(Entity.IsClass, "Class ", "Module ")
EmitId 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
EmitAttributes Entity.Attributes

For Each Ipl In Entity.Impls
EmitImplements Ipl
.AppendLn
Sep = True
Next

If Sep And Entity.Events.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Evt In Entity.Events
EmitEvent Evt
.AppendLn
Sep = True
Next

If Sep And Entity.Types.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Typ In Entity.Types
EmitType Typ
.AppendLn

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
EmitDim Var
.AppendLn
Sep = True
Next

If Sep And Entity.Consts.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Cnt In Entity.Consts
EmitConst Cnt
.AppendLn
Sep = True
Next

If Sep And Entity.Declares.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Dcl In Entity.Declares
EmitDeclare 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
EmitEnum Enm
.AppendLn

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
EmitAccess Fnc.Access
If Fnc.IsStatic Then .Append "Static "
If Fnc.IsDefault Then .Append "Default "
If Fnc.IsIterator Then .Append "Iterator "
.Append "Function "
EmitId Fnc.Id
EmitParams Fnc.Parameters
.Append " As "
EmitDataType Fnc.DataType
.AppendLn
.Indent
EmitAttributes Fnc.Attributes
EmitBody Fnc.Body
.Deindent
.AppendLn "End Function"

Count += 1
If Count <> Entity.Functions.Count Then .AppendLn
Sep = True
Next

If Sep AndAlso Entity.Subs.Count > 0 Then
.AppendLn
Sep = False
End If

Count = 0

For Each Prc In Entity.Subs
EmitAccess Prc.Access
If Prc.IsStatic Then .Append "Static "
If Prc.IsDefault Then .Append "Default "
.Append "Sub "
EmitId Prc.Id
EmitParams Prc.Parameters
.AppendLn
.Indent
EmitAttributes Prc.Attributes
EmitBody Prc.Body
.Deindent
.AppendLn "End Sub"
Sep = True
Count += 1
If Count <> Entity.Subs.Count Then .AppendLn
Next

If Sep AndAlso 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)
EmitAccess Prp.Access
If Prp.IsStatic Then .Append "Static "
If Prp.IsDefault Then .Append "Default "

.Append "Property Get "
EmitId Slt.Id
EmitParams Prp.Parameters
.Append " As "
EmitDataType Slt.DataType
.AppendLn

.Indent
EmitAttributes Prp.Attributes
EmitBody Prp.Body
.Deindent
.AppendLn "End Property"

If Slt.Exists(VbLet) OrElse Slt.Exists(VbSet) Then .AppendLn
End If

If Slt.Exists(VbLet) Then
Set Prp = Slt(VbLet)
EmitAccess Prp.Access
If Prp.IsStatic Then .Append "Static "
If Prp.IsDefault Then .Append "Default "

.Append "Property Let "
EmitId Slt.Id
EmitParams Prp.Parameters
.AppendLn

.Indent
EmitBody Prp.Body
.Deindent
.AppendLn "End Property"
If Slt.Exists(VbSet) Then .AppendLn
End If

If Slt.Exists(VbSet) Then
Set Prp = Slt(VbSet)
EmitAccess Prp.Access
If Prp.IsStatic Then .Append "Static "
If Prp.IsDefault Then .Append "Default "

.Append "Property Set "
EmitId Slt.Id
EmitParams Prp.Parameters
.AppendLn

.Indent
EmitBody Prp.Body
.Deindent
.AppendLn "End Property"
End If

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 EmitAttributes(ByVal Attrs As KeyedList)
Dim Attr As AttributeConstruct

For Each Attr In Attrs
Builder.Append "Attribute "

If Attr.Id.Project IsNot Nothing Then
EmitToken Attr.Id.Project
Builder.Append "."
End If

EmitToken Attr.Id.Name
Builder.Append "="
EmitExpression Attr.Value
Builder.AppendLn
Next
End Sub

Private Sub EmitAccess(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 EmitImplements(ByVal Ipl As ImplementsConstruct)
Builder.Append "Implements "
EmitId Ipl.Id
End Sub

Private Sub EmitEvent(ByVal Evt As EventConstruct)
EmitAccess Evt.Access
Builder.Append "Event "
EmitId Evt.Id
EmitParams Evt.Parameters
End Sub

Private Sub EmitId(ByVal Id As Identifier)
If Id.Project IsNot Nothing Then
EmitToken Id.Project
Builder.Append "."
End If

EmitToken Id.Name
End Sub

Private Sub EmitParams(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

EmitId Parm.Id
If Parm.IsArray Then Builder.Append "()"

Builder.Append " As "
EmitDataType Parm.DataType

If Parm.Init IsNot Nothing Then
Builder.Append " = "
EmitExpression Parm.Init
End If

If Idx <> Params.Count Then Builder.Append ", "
Next

Builder.Append ")"
End Sub

Private Sub EmitDataType(ByVal DataType As DataType)
EmitId DataType.Id

If DataType.FixedLength IsNot Nothing Then
Builder.Append " * "
EmitExpression DataType.FixedLength
End If
End Sub

Private Sub EmitType(ByVal Typ As TypeConstruct)
Dim Mem As Variable

EmitAccess Typ.Access
Builder.Append "Type "
EmitId Typ.Id
Builder.AppendLn
Builder.Indent

For Each Mem In Typ.Members
EmitId Mem.Id
Builder.Append " As "
EmitDataType Mem.DataType

If Mem.DataType.IsArray AndAlso Mem.Subscripts.Count = 0 Then
Builder.Append "()"
Else
EmitSubscripts Mem.Subscripts
End If

Builder.AppendLn
Next

Builder.Deindent
Builder.Append "End Type"
End Sub

Private Sub EmitSubscripts(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)

EmitExpression Pair.LowerBound
Builder.Append " To "
EmitExpression Pair.UpperBound

If Idx <> Subscripts.Count Then Builder.Append ", "
Next

Builder.Append ")"
End Sub

Private Sub EmitConst(ByVal Cnt As ConstConstruct)
If Cnt.Access = acLocal Then Builder.Deindent

EmitAccess Cnt.Access
Builder.Append "Const "
EmitId Cnt.Id

If Cnt.DataType IsNot Nothing Then
Builder.Append " As "
EmitDataType Cnt.DataType
End If

If Cnt.Value IsNot Nothing Then
Builder.Append " = "
EmitExpression Cnt.Value
End If

If Cnt.Access = acLocal Then Builder.Indent
End Sub

Private Sub EmitDeclare(ByVal Dcl As DeclareConstruct)
EmitAccess Dcl.Access
Builder.Append "Declare "
Builder.Append IIf(Dcl.IsSub, "Sub ", "Function ")
EmitId Dcl.Id
If Dcl.IsCDecl Then Builder.Append " CDecl"
Builder.Append " Lib "
EmitToken Dcl.LibName
Builder.Append " "

If Dcl.AliasName IsNot Nothing Then
Builder.Append "Alias "
EmitToken Dcl.AliasName
End If

EmitParams Dcl.Parameters

If Not Dcl.IsSub Then
Builder.Append " As "
EmitDataType Dcl.DataType
End If
End Sub

Private Sub EmitEnum(ByVal Enm As EnumConstruct)
Dim Mem As EnumerandConstruct

EmitAccess Enm.Access
Builder.Append "Enum "
EmitId Enm.Id
Builder.AppendLn
Builder.Indent

For Each Mem In Enm.Enumerands
EmitId Mem.Id

If Mem.Value IsNot Nothing Then
Builder.Append " = "
EmitExpression Mem.Value
End If

Builder.AppendLn
Next

Builder.Deindent
Builder.Append "End Enum"
End Sub

Private Sub EmitExpression(ByVal Expr As IExpression, Optional ByVal Op As Operator)
Dim Par As Boolean
Dim Idx As Integer
Dim Sym As Symbol
Dim Lit As Literal
Dim Hnd As FileHandle
Dim Exr As IExpression
Dim Tup As TupleConstruct
Dim Uni As UnaryExpression
Dim Bin As BinaryExpression

Select Case Expr.Kind
Case ekLiteral
Set Lit = Expr
EmitToken Lit.Value

Case ekSymbol
Set Sym = Expr
EmitToken Sym.Value

Case ekFileHandle
Set Hnd = Expr
Builder.Append "#"
EmitToken Hnd.Value

Case ekTuple
Set Tup = Expr

For Idx = 1 To Tup.Elements.Count
Set Exr = Tup.Elements(Idx)
EmitExpression Exr
If Idx <> Tup.Elements.Count Then Builder.Append ", "
Next

Case ekUnaryExpr
Set Uni = Expr
EmitOperator Uni.Operator
EmitExpression Uni.Value

Case ekBinaryExpr
Set Bin = Expr
If Op IsNot Nothing Then Par = ComparePrecedence(Op, Bin.Operator) = 1
If Par Then Builder.Append "("

EmitExpression Bin.LHS, Bin.Operator
EmitOperator Bin.Operator
EmitExpression Bin.RHS, Bin.Operator

If Par Then Builder.Append ")"

Case ekIndexer
EmitCall Expr
End Select
End Sub

Private Sub EmitBody(ByVal Body As KeyedList)
Dim Stmt As IStmt

For Each Stmt In Body
EmitStmt Stmt
Builder.AppendLn
Next
End Sub

Private Sub EmitStmt(ByVal Stmt As IStmt)
Select Case Stmt.Kind
Case snCall
Builder.Append "Call "
EmitCall Stmt

Case snClose
EmitClose Stmt

Case snConst
EmitConst Stmt

Case snContinue
EmitContinue Stmt

Case snDebug
EmitDebug Stmt

Case snDim
EmitDim Stmt

Case snDo
EmitDo Stmt

Case snEnd
EmitEnd Stmt

Case snErase
EmitErase Stmt

Case snExit
EmitExit Stmt

Case snFor
EmitFor Stmt

Case snForEach
EmitForEach Stmt

Case snGet
EmitGet Stmt

Case snGoSub
EmitGoSub Stmt

Case snGoTo
EmitGoTo Stmt

Case snIf
EmitIf Stmt

Case snInput
EmitInput Stmt

Case snLabel
EmitLabel Stmt

Case snLet
EmitLet Stmt

Case snLineNumber
EmitLineNumber Stmt

Case snLock
EmitLock Stmt

Case snLSet
EmitLSet Stmt

Case snName
EmitName Stmt

Case snOnError
EmitOnError Stmt

Case snOnComputed
EmitOnComputed Stmt

Case snOpen
EmitOpen Stmt

Case snPrint
EmitPrint Stmt

Case snPut
EmitPut Stmt

Case snRaiseEvent
EmitRaiseEvent Stmt

Case snReDim
EmitReDim Stmt

Case snReset
EmitReset Stmt

Case snResume
EmitResume Stmt

Case snReturn
EmitReturn Stmt

Case snRSet
EmitRSet Stmt

Case snSeek
EmitSeek Stmt

Case snSelect
EmitSelect Stmt

Case snSet
EmitSet Stmt

Case snStop
EmitStop Stmt

Case snUnlock
EmitUnlock Stmt

Case snWhile
EmitWhile Stmt

Case snWidth
EmitWidth Stmt

Case snWith
EmitWith Stmt

Case snWrite
EmitWrite Stmt
End Select
End Sub

Private Sub EmitCall(ByVal Stmt As CallConstruct)
Dim Count As Integer
Dim Expr As IExpression

EmitExpression Stmt.LHS

If Stmt.Arguments.Count > 0 Then
Builder.Append "("

For Each Expr In Stmt.Arguments
EmitExpression Expr
Count += 1
If Count <> Stmt.Arguments.Count Then Builder.Append ", "
Next

Builder.Append ")"
End If
End Sub

Private Sub EmitClose(ByVal Stmt As CloseConstruct)
Dim Number As IExpression

Builder.Append "Close"

For Each Number In Stmt.FileNumbers
Builder.Append " "
EmitExpression Number
Next
End Sub

Private Sub EmitContinue(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 EmitDebug(ByVal Stmt As DebugConstruct)
Stop
End Sub

Private Sub EmitDim(ByVal Stmt As Variable)
If Stmt.Access = acLocal Then
Builder.Deindent
Builder.Append "Dim "
Else
EmitAccess Stmt.Access
End If

If Stmt.HasWithEvents Then Builder.Append "WithEvents "
EmitId Stmt.Id
EmitSubscripts Stmt.Subscripts
Builder.Append " As "
If Stmt.HasNew Then Builder.Append "New "
EmitDataType Stmt.DataType

If Stmt.Init IsNot Nothing Then
Builder.Append " = "
EmitExpression Stmt.Init
End If

If Stmt.Access = acLocal Then Builder.Indent
End Sub

Private Sub EmitDo(ByVal Stmt As DoConstruct)
Builder.Append "Do"

Select Case Stmt.DoType
Case dtDoWhileLoop
Builder.Append " While "
EmitExpression Stmt.Condition

Case dtDoUntilLoop
Builder.Append " Until "
EmitExpression Stmt.Condition
End Select

Builder.AppendLn
Builder.Indent

EmitBody Stmt.Body

Builder.Deindent
Builder.Append "Loop"

Select Case Stmt.DoType
Case dtDoLoopWhile
Builder.Append " While "
EmitExpression Stmt.Condition

Case dtDoLoopUntil
Builder.Append " Until "
EmitExpression Stmt.Condition
End Select
End Sub

Private Sub EmitEnd(ByVal Stmt As EndConstruct)
Builder.Append "End"
End Sub

Private Sub EmitErase(ByVal Stmt As EraseConstruct)
Dim Count As Integer
Dim Var As Variable

Builder.Append "Erase "

For Each Var In Stmt.Vars
EmitId Var.Id
Count += 1
If Count <> Stmt.Vars.Count Then Builder.Append ", "
Next

Builder.Append " "
End Sub

Private Sub EmitExit(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 EmitFor(ByVal Stmt As ForConstruct)
Dim Lit As Literal
Dim HasStep As Boolean

Builder.Append "For "
EmitToken Stmt.Counter.Value
Builder.Append " = "
EmitExpression Stmt.StartValue
Builder.Append " To "
EmitExpression Stmt.EndValue

If Stmt.Increment.Kind = ekLiteral Then: Set Lit = Stmt.Increment: HasStep = Lit.Value.Line <> 0 OrElse Lit.Value.Column <> 0

If HasStep Then
Builder.Append " Step "
EmitExpression Stmt.Increment
End If

Builder.AppendLn
Builder.Indent

EmitBody Stmt.Body

Builder.Deindent
Builder.Append "Next"
End Sub

Private Sub EmitForEach(ByVal Stmt As ForEachConstruct)
Builder.Append "For Each "
EmitToken Stmt.Element.Value
Builder.Append " In "
EmitExpression Stmt.Group

Builder.AppendLn
Builder.Indent

EmitBody Stmt.Body

Builder.Deindent
Builder.Append "Next"
End Sub

Private Sub EmitGet(ByVal Stmt As GetConstruct)
Builder.Append "Get "
EmitExpression Stmt.FileNumber
Builder.Append ", "
If Stmt.RecNumber IsNot Nothing Then EmitExpression Stmt.RecNumber
Builder.Append ", "
EmitToken Stmt.Var.Value
End Sub

Private Sub EmitGoSub(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
EmitToken LinNum.Value
Else
Set Label = Stmt.Target
EmitId Label.Id
End If
End Sub

Private Sub EmitGoTo(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
EmitToken LinNum.Value
Else
Set Label = Stmt.Target
EmitId Label.Id
End If
End Sub

Private Sub EmitIf(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 "
EmitExpression Arm.Condition
Builder.Append " Then "
EmitStmt Arm.Body(1)

If Stmt.ElseBody.Count = 1 Then
Builder.Append " Else "
EmitStmt 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)
EmitExpression Arm.Condition
Builder.AppendLn " Then"

Builder.Indent
EmitBody Arm.Body
Builder.Deindent
Next

If Stmt.ElseBody.Count > 0 Then
Builder.AppendLn "Else"
Builder.Indent
EmitBody Stmt.ElseBody
Builder.Deindent
End If

Builder.Append "End If"
End If
End Sub

Private Sub EmitInput(ByVal Stmt As InputConstruct)
Dim Count As Integer
Dim Var As Symbol

Builder.Append "Input "
EmitExpression Stmt.FileNumber
Builder.Append ", "

For Each Var In Stmt.Vars
EmitToken Var.Value
Count += 1
If Count <> Stmt.Vars.Count Then Builder.Append ", "
Next
End Sub

Private Sub EmitLabel(ByVal Stmt As LabelConstruct)
Builder.Append NameBank(Stmt.Id.Name)
Builder.Append ": "
End Sub

Private Sub EmitLet(ByVal Stmt As LetConstruct)
EmitExpression Stmt.Name
EmitOperator Stmt.Operator
EmitExpression Stmt.Value
End Sub

Private Sub EmitLineNumber(ByVal Stmt As LineNumberConstruct)
EmitToken Stmt.Value
End Sub

Private Sub EmitLock(ByVal Stmt As LockConstruct)
Builder.Append "Lock "
EmitExpression Stmt.FileNumber
Builder.Append ", "
EmitExpression Stmt.RecordRange
End Sub

Private Sub EmitLSet(ByVal Stmt As LSetConstruct)
Builder.Append "LSet "
EmitExpression Stmt.Name
Builder.Append " = "
EmitExpression Stmt.Value
End Sub

Private Sub EmitName(ByVal Stmt As NameConstruct)
Builder.Append "Name "
EmitExpression Stmt.OldPathName
Builder.Append " As "
EmitExpression Stmt.NewPathName
End Sub

Private Sub EmitOnError(ByVal Stmt As OnErrorConstruct)
Builder.Append "On Error "

If Stmt.Statement.Kind = snGoTo Then
EmitGoTo Stmt.Statement

ElseIf Stmt.Statement.Kind = snResume Then
EmitResume Stmt.Statement
End If
End Sub

Private Sub EmitOnComputed(ByVal Stmt As OnComputedConstruct)
Dim Count As Integer
Dim Target As IStmt
Dim Label As LabelConstruct

Builder.Append "On "
EmitExpression 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
EmitId Label.Id
Else
EmitLineNumber Target
End If

Count += 1
If Count <> Stmt.Targets.Count Then Builder.Append ", "
Next
End Sub

Private Sub EmitOpen(ByVal Stmt As OpenConstruct)
Builder.Append "Open "
EmitExpression 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 "
EmitExpression Stmt.FileNumber

If Stmt.Length IsNot Nothing Then
Builder.Append " Len="
EmitExpression Stmt.Length
End If
End Sub

Private Sub EmitPrint(ByVal Stmt As PrintConstruct)
Dim Count As Integer
Dim Arg As PrintArg

Builder.Append "Print #"
EmitExpression Stmt.FileNumber
Builder.Append ","

For Each Arg In Stmt.Output
Count += 1

If Arg.Indent IsNot Nothing Then
Builder.Append IIf(Arg.Indent.IsTab, " Tab", " Spc")

If Arg.Indent.Value IsNot Nothing Then
Builder.Append "("
EmitExpression Arg.Indent.Value
Builder.Append ")"
End If

Builder.Append " "
End If

EmitExpression Arg.Value

If Arg.HasSemicolon Then
Builder.Append ";"

ElseIf Count <> Stmt.Output.Count Then
Builder.Append " "
End If
Next
End Sub

Private Sub EmitPut(ByVal Stmt As PutConstruct)
Builder.Append "Put "
EmitExpression Stmt.FileNumber
Builder.Append ", "
If Stmt.RecNumber IsNot Nothing Then EmitExpression Stmt.RecNumber
Builder.Append ", "
EmitToken Stmt.Var.Value
End Sub

Private Sub EmitRaiseEvent(ByVal Stmt As RaiseEventConstruct)
Dim Count As Integer
Dim Expr As IExpression

Builder.Append "RaiseEvent "
EmitId Stmt.Id

If Stmt.Arguments.Count > 0 Then
Builder.Append "("

For Each Expr In Stmt.Arguments
EmitExpression Expr
Count += 1
If Count <> Stmt.Arguments.Count Then Builder.Append ", "
Next

Builder.Append ")"
End If

Builder.Append " "
End Sub

Private Sub EmitReDim(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
EmitId Var.Id
EmitSubscripts Var.Subscripts
Builder.Append " As "
EmitDataType Var.DataType
Count += 1
If Count <> Stmt.Vars.Count Then Builder.Append ", "
Next
End Sub

Private Sub EmitReset(ByVal Stmt As ResetConstruct)
Builder.Append "Reset"
End Sub

Private Sub EmitResume(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
EmitId Label.Id
Else
Set LinNum = Stmt.Target

If LinNum.Value.Text <> "0" Then
Builder.Append " "
EmitToken LinNum.Value
End If
End If
End Sub

Private Sub EmitReturn(ByVal Stmt As ReturnConstruct)
Builder.Append "Return "
End Sub

Private Sub EmitRSet(ByVal Stmt As RSetConstruct)
Builder.Append "RSet "
EmitExpression Stmt.Name
Builder.Append " = "
EmitExpression Stmt.Value
End Sub

Private Sub EmitSeek(ByVal Stmt As SeekConstruct)
Builder.Append "Seek "
EmitExpression Stmt.FileNumber
Builder.Append ", "
EmitExpression Stmt.Position
End Sub

Private Sub EmitSelect(ByVal Stmt As SelectConstruct)
Dim Count As Integer
Dim Cond As IExpression
Dim Cs As CaseConstruct
Dim Bin As BinaryExpression

Builder.Append "Select Case "
EmitExpression Stmt.Value
Builder.AppendLn
Builder.Indent

For Each Cs In Stmt.Cases
Count = 0
Builder.Append "Case "

For Each Cond In Cs.Conditions
Count += 1

If Cond.Kind = ekBinaryExpr Then
Set Bin = Cond

If Bin.LHS Is Nothing Then
Builder.Append "Is"
EmitOperator Bin.Operator
Set Cond = Bin.RHS
End If
End If

EmitExpression Cond
If Count <> Cs.Conditions.Count Then Builder.Append ", "
Next

Builder.AppendLn
Builder.Indent
EmitBody Cs.Body
Builder.Deindent
Next

If Stmt.CaseElse.Count > 0 Then
Builder.AppendLn "Case Else"
Builder.Indent
EmitBody Stmt.CaseElse
Builder.Deindent
End If

Builder.Deindent
Builder.Append "End Select"
End Sub

Private Sub EmitSet(ByVal Stmt As SetConstruct)
Builder.Append "Set "
EmitExpression Stmt.Name
Builder.Append " = "
EmitExpression Stmt.Value
End Sub

Private Sub EmitStop(ByVal Stmt As StopConstruct)
Builder.Append "Stop "
End Sub

Private Sub EmitUnlock(ByVal Stmt As UnlockConstruct)
Builder.Append "Unlock "
EmitExpression Stmt.FileNumber
Builder.Append ", "
EmitExpression Stmt.RecordRange
End Sub

Private Sub EmitWhile(ByVal Stmt As WhileConstruct)
Builder.Append "While "
EmitExpression Stmt.Condition

Builder.AppendLn
Builder.Indent

EmitBody Stmt.Body

Builder.Deindent
Builder.Append "Wend"
End Sub

Private Sub EmitWidth(ByVal Stmt As WidthConstruct)
Builder.Append "Width "
EmitExpression Stmt.FileNumber
Builder.Append ", "
EmitExpression Stmt.Value
End Sub

Private Sub EmitWith(ByVal Stmt As WithConstruct)
Builder.Append "With "
EmitExpression Stmt.PinObject
Builder.AppendLn

Builder.Indent
EmitBody Stmt.Body
Builder.Deindent

Builder.Append "End With"
End Sub

Private Sub EmitWrite(ByVal Stmt As WriteConstruct)
Dim Count As Integer
Dim Expr As IExpression

Builder.Append "Write "
EmitExpression Stmt.FileNumber
Builder.Append ", "

For Each Expr In Stmt.Output
EmitExpression Expr
Count += 1
If Count <> Stmt.Output.Count Then Builder.Append ", "
Next
End Sub

Private Sub EmitToken(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
Builder.Append "["
Builder.Append NameBank(Stmt)
Builder.Append "]"

Case tkFileHandle, tkFloatNumber, tkIntegerNumber, tkSciNumber
If Left$(Stmt.Text, 1) = "-" Then Builder.Append "-"
Builder.Append Mid$(Stmt.Text, 2)

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
Err.Raise 5
End Select

If Stmt.Suffix <> vbNullChar Then Builder.Append Stmt.Suffix
End Sub

Private Sub EmitOperator(ByVal Stmt As Operator)
If Stmt.IsUnary Then
EmitToken Stmt.Value

Select Case Stmt.Value.Code
Case opWithBang, opWithDot, opNeg
Exit Select

Case Else
Builder.Append " "
End Select

Else
Select Case Stmt.Value.Code
Case opDot, opBang, opNamed
EmitToken Stmt.Value

Case Else
Builder.Append " "
EmitToken Stmt.Value
Builder.Append " "
End Select
End If
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 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
kwDebug ' 18
kwDeclare ' 19
kwDefault ' 20
kwDefBool ' 21
kwDefByte ' 22
kwDefCur ' 23
kwDefDate ' 24
kwDefDbl ' 25
kwDefDec ' 26
kwDefInt ' 27
kwDefLng ' 28
kwDefLngLng ' 29
kwDefLngPtr ' 30
kwDefObj ' 31
kwDefSng ' 32
kwDefStr ' 33
kwDefVar ' 34
kwDim ' 35
kwDo ' 36
kwDouble ' 37
kwEach ' 38
kwElse ' 39
kwElseIf ' 40
kwEmpty ' 41
kwEnd ' 42
kwEndIf ' 43
kwEnum ' 44
kwErase ' 45
kwEvent ' 46
kwExit ' 47
kwFalse ' 48
kwFor ' 49
kwFriend ' 50
kwFunction ' 51
kwGet ' 52
kwGlobal ' 53
kwGoSub ' 54
kwGoTo ' 55
kwIf ' 56
kwImplements ' 57
kwIn ' 58
kwInput ' 59
kwInteger ' 60
kwIterator ' 61
kwLet ' 62
kwLocal ' 63
kwLong ' 64
kwLongLong ' 65
kwLongPtr ' 66
kwLoop ' 67
kwLSet ' 68
kwMe ' 69
kwModule ' 70
kwNext ' 71
kwNothing ' 72
kwNull ' 73
kwOn ' 74
kwOpen ' 75
kwOption ' 76
kwOptional ' 77
kwParamArray ' 78
kwPreserve ' 79
kwPrint ' 80
kwPrivate ' 81
kwPSet ' 82
kwPublic ' 83
kwPut ' 84
kwRaiseEvent ' 85
kwReDim ' 86
kwRem ' 87
kwResume ' 88
kwReturn ' 89
kwRSet ' 90
kwScale ' 91
kwSeek ' 92
kwSelect ' 93
kwSet ' 94
kwSingle ' 95
kwStatic ' 96
kwStop ' 97
kwString ' 98
kwSub ' 99
kwThen '100
kwTo '101
kwTrue '102
kwType '103
kwUnlock '104
kwUntil '105
kwVariant '106
kwVoid '107
kwWend '108
kwWhile '109
kwWith '110
kwWithEvents '111
kwWrite '112
End Enum

Public Enum ContextualNumbers
cxAccess = kwWrite + 1 '113
cxAlias ' 2 / 114
cxAppend ' 3 / 115
cxBase ' 4 / 116
cxBinary ' 5 / 117
cxCompare ' 6 / 118
cxDecimal ' 7 / 119
cxError ' 8 / 120
cxExplicit ' 9 / 121
cxLen '10 / 122
cxLib '11 / 123
cxLine '12 / 124
cxLock '13 / 125
cxName '14 / 126
cxObject '15 / 127
cxOutput '16 / 128
cxProperty '17 / 129
cxPtrSafe '18 / 130
cxRandom '19 / 131
cxRead '20 / 132
cxReset '21 / 133
cxShared '22 / 134
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
opId '12 (~+)
opNeg '13 (~-)
opLt '14 (<)
opLe '15 (<=)
opEq '16 (=)
opGe '17 (>=)
opGt '18 (>)
opNe '19 (<>)
opNamed '20 (:=)
opWithDot '21 (~.)
opWithBang '22 (~!)
opDot '23 (.)
opBang '24 (!)
opAnd '25
opEqv '26
opImp '27
opMod '28
opOr '29
opXor '30
opSum '31 (+)
opSubt '32 (-)
opMul '33 (*)
opDiv '34 (/)
opIntDiv '35 (\)
opPow '36 (^)
opLSh '37 (<<)
opRSh '38 (>>)
opURSh '39 (>>>)
opConcat '40 (&)
opCompAnd '41 (And=)
opCompEqv '42 (Eqv=)
opCompImp '43 (Imp=)
opCompMod '44 (Mod=)
opCompOr '45 (Or=)
opCompXor '46 (Xor=)
opCompSum '47 (+=)
opCompSubt '48 (-=)
opCompMul '49 (*=)
opCompDiv '50 (/=)
opCompIntDiv '51 (\=)
opCompPow '52 (^=)
opCompLSh '53 (<<=)
opCompRSh '54 (>>=)
opCompURSh '55 (>>>=)
opCompConcat '56 (&=)
opApply '57 ()
End Enum

Private Sub Class_Initialize()
RunningLine_ = 0
RunningColumn_ = 1
End Sub

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

Public Sub OpenFile(ByVal FilePath As String)
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

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

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

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

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

Select Case Ch
Case "["
Set Token = ReadEscapedIdentifier

Case """"
Set Token = ReadString

Case "&"
Set Token = ReadAmpersand

Case "#"
Set Token = ReadHash

Case "0" To "9"
Set Token = ReadNumber(Ch)
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 <= CStr(9_223_372_036_854_775_807)
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
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 "`"
Done = False
DiscardComment
Set Token = New Token

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

Set Token = ReadIdentifier(Cp)

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

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

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

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

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

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

Set GetToken = Token
End Function

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

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

Select Case Cp1
Case SP_
Cp2 = NextCodePoint

If Cp2 = US_ Then
Cp3 = NextCodePoint

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

Case LF_
AdvanceLine
Cp1 = BS_

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

Case CR_
CheckLF = True
Cp1 = LF_
End Select

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

If Cp1 = LF_ Then AdvanceLine
GetCodePoint = Cp1
End Function

Private Function NextCodePoint() As Integer
Dim Result As Integer

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

Private Function GetChar() As String
Dim Cp As Integer = 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 >> 8
ToChar = Bytes
End Function

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

Private Sub UngetChar(ByVal Character As String)
Dim Length As Long = SizeOf(kwInteger)
If Character = vbBack Then Length = Length * 2 + Len(vbNewLine) * SizeOf(kwInteger)
Dim Pos As Long = Seek(File_)
Seek #File_, Pos - Length

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

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 Suffix As String * 1
Dim Buffer As String * MAX_LENGTH
Dim Result As Token

Dim Count As Integer = 1
Mid$(Buffer, Count, 1) = ChrW(CodePoint)

Do Until AtEnd
Dim Cp As Integer = GetCodePoint
Dim Ch As String * 1 = ToChar(Cp)

If Ch <> "_" AndAlso _
(Ch < "0" OrElse Ch > "9") AndAlso _
Not IsLetter(Cp) AndAlso _
Not IsSurrogate(Cp) Then _
Exit Do

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

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

Case Else
UngetChar Ch
End Select

Set Result = NewToken(tkIdentifier, Suffix:=Suffix)
Dim Name As String = Left$(Buffer, Count)
Dim Index As Long = 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 += NameBank.Keywords.Count + NameBank.Contextuals.Count
End If
End If
End If

Select Case Result.Kind
Case tkKeyword, tkOperator
If Result.Suffix <> vbNullChar Then
If Index = kwString AndAlso Result.Suffix = "$" Then
Result.Kind = tkIdentifier
Index = NameBank.Ids.IndexOf(V.String) + NameBank.Keywords.Count + NameBank.Contextuals.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 Count As Integer
Dim Suffix As String * 1
Dim Buffer As String * MAX_LENGTH
Dim Token As Token

Do Until AtEnd
Dim Cp As Integer = GetCodePoint
If Cp = AscW("]") Then Exit Do
If Cp = LF_ Then Fail "Invalid identifier"

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 "%", "&", "^", "@", "!", "#", "$"
Exit Select

Case Else
UngetChar Suffix
Suffix = vbNullChar
End Select
End If

Set Token = NewToken(tkEscapedIdentifier, Suffix:=Suffix)
Dim Name As String = 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.Keywords.Count + NameBank.Contextuals.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 += 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 Count As Integer
Dim Ch As String * 1
Dim Suffix As String * 1
Dim Buffer As String * MAX_LENGTH

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

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

Select Case Ch
Case "0" To "9"
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 Result As Token
Dim FracPart As Token

Set Result = ReadInteger(FirstDigit:=FirstDigit)

If Result.Suffix = vbNullChar AndAlso Not AtEnd Then
Dim Ch As String * 1 = GetChar

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

Set ReadFloat = Result
End Function

Private Function ReadNumber(ByVal FirstDigit As String) As Token
Dim Result As Token
Dim ExpPart As Token

Set Result = ReadFloat(FirstDigit)

If Result.Suffix = vbNullChar AndAlso Not AtEnd Then
Dim Ch As String * 1 = GetChar

Select Case Ch
Case "e", "E"
If AtEnd Then
UngetChar Ch
Else
Dim Sg As String * 1 = GetChar

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

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

Case Else
UngetChar Ch
End Select
End If

Result.Text = Result.Text
Set ReadNumber = Result
End Function

Private Function ReadAmpersand() As Token
Dim Token As Token

Dim Ch As String * 1 = 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 Number As Integer
Dim Name As String
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.
Dim Cp As Integer = GetCodePoint
Dim Ch As String * 1 = 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 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.
Dim Ch As String * 1 = GetChar
If Ch <> Separator Then Fail Msg_

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

If CInt(FirstNumber) >= 100 AndAlso 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 += 1900
If YYYY < 1950 Then YYYY += 100
End If
End If

Rem Validate year.
If YYYY > 9999 Then Fail Msg_

Rem Validate month.
If MM < 1 OrElse 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 AndAlso YYYY Mod 100 <> 0 OrElse 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 &= "0"
If YYYY < 10 Then Result &= "0"
Result &= CStr(YYYY)
Result &= "-"

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

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

ReadDate = Result
End Function

Private Function ReadTime(Optional ByVal FirstNumber As String) As String
Dim SS As Integer
Dim Ch2 As String * 1
Dim AP As String * 1

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

Dim Ch As String * 1 = 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" OrElse Ch = "A" Then
Ch2 = GetChar

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

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

If Ch2 = "m" OrElse 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 OrElse HH > 23 Then Err.Raise 0
If NN < 0 OrElse NN > 59 Then Err.Raise 0
If SS < 0 OrElse 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 += 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

Do Until AtEnd
Dim Prv As String * 1 = Ch
Dim Ch As String * 1 = 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 &= 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 += 1

If StrComp(Name, MonthName, vbTextCompare) = 0 Then Result = Count
If Result = 0 AndAlso 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 += 1
Mid$(Buffer, Count, 1) = Ch
Loop

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

Private Sub DiscardComment()
Dim Count As Long = 1

Do Until AtEnd
Dim Ch As String * 1 = GetChar

Select Case Ch
Case "`"
Count += 1

Case "´"
Count -= 1
If Count = 0 Then Exit Do
End Select
Loop
End Sub

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 Count As Integer
Dim Ch As String * 1
Dim Suffix As String * 1
Dim Buffer As String * 96

Dim Skip As Boolean = 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 += 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
End Class

Public Class StmtValidator
Option Explicit
Implements IKLValidator

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

Public Class StopConstruct
Option Explicit
Implements IStmt

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

Public Class SubConstruct
Option Explicit

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

Public Class SubscriptPair
Option Explicit

Private UpperBound_ As IExpression

Public LowerBound As IExpression

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

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

Public Class Symbol
Option Explicit
Implements IExpression

Public Value As Token

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

Public Class Token
Option Explicit

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

Public 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 AndAlso Me.Code = Code
End Function

Public Function IsOperator(ByVal Code As Long) As Boolean
IsOperator = Kind = tkOperator AndAlso 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
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 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 Obj As IEnumVariantType

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

With Obj
.VTable = Ptr + SizeOf(cxObject)
.QueryInterface = AddressOf QueryInterfaceEntry
.AddRef = AddressOf AddRefEntry
.Release = AddressOf ReleaseEntry
.NextItem = AddressOf NextEntry
.Skip = AddressOf SkipEntry
.Reset = AddressOf ResetEntry
.Clone = 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 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 [ByVal]() As String
[ByVal] = "ByVal"
End Property

Public Property Get [Byte]() As String
[Byte] = "Byte"
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 [Debug]() As String
[Debug] = "Debug"
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 [ElseIf]() As String
[ElseIf] = "ElseIf"
End Property

Public Property Get [Else]() As String
[Else] = "Else"
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 [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 [Lock]() As String
[Lock] = "Lock"
End Property

Public Property Get [Local]() As String
[Local] = "Local"
End Property

Public Property Get [Long]() As String
[Long] = "Long"
End Property

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

Rem New!
Public Property Get [LongLong]() As String
[LongLong] = "LongLong"
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 [Len]() As String
[Len] = "Len"
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"
End Property

Public Property Get [Nothing]() As String
[Nothing] = "Nothing"
End Property

Public Property Get [Null]() As String
[Null] = "Null"
End Property

Rem Contextual in VB6
Public Property Get [Object]() As String
[Object] = "Object"
End Property

Public Property Get [On]() As String
[On] = "On"
End Property

Public Property Get [Open]() As String
[Open] = "Open"
End Property

Public Property Get [Option]() As String
[Option] = "Option"
End Property

Public Property Get [Optional]() As String
[Optional] = "Optional"
End Property

Public Property Get [Or]() As String
[Or] = "Or"
End Property

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

Rem Contextual in VB6
Public Property Get [Output]() As String
[Output] = "Output"
End Property

Public Property Get [ParamArray]() As String
[ParamArray] = "ParamArray"
End Property

Public Property Get [PSet]() As String
[PSet] = "PSet"
End Property

Public Property Get [Preserve]() As String
[Preserve] = "Preserve"
End Property

Public Property Get [Print]() As String
[Print] = "Print"
End Property

Public Property Get [Private]() As String
[Private] = "Private"
End Property

Public Property Get [Property]() As String
[Property] = "Property"
End Property

Rem New!
Public Property Get [PtrSafe]() As String
[PtrSafe] = "PtrSafe"
End Property

Public Property Get [Public]() As String
[Public] = "Public"
End Property

Public Property Get [Put]() As String
[Put] = "Put"
End Property

Public Property Get [RaiseEvent]() As String
[RaiseEvent] = "RaiseEvent"
End Property

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

Rem Contextual in VB6
Public Property Get [Read]() As String
[Read] = "Read"
End Property

Public Property Get [ReDim]() As String
[ReDim] = "ReDim"
End Property

Public Property Get [Rem]() As String
[Rem] = "Rem"
End Property

Rem Contextual in VB6
Public Property Get [Reset]() As String
[Reset] = "Reset"
End Property

Public Property Get [Resume]() As String
[Resume] = "Resume"
End Property

Public Property Get [Return]() As String
[Return] = "Return"
End Property

Public Property Get [RSet]() As String
[RSet] = "RSet"
End Property

Public Property Get [Seek]() As String
[Seek] = "Seek"
End Property

Public Property Get [Select]() As String
[Select] = "Select"
End Property

Public Property Get [Set]() As String
[Set] = "Set"
End Property

Public Property Get [Scale]() As String
[Scale] = "Scale"
End Property

Public Property Get [Shared]() As String
[Shared] = "Shared"
End Property

Public Property Get [Single]() As String
[Single] = "Single"
End Property

Public Property Get [Static]() As String
[Static] = "Static"
End Property

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

Rem Contextual in VB6
Public Property Get [Step]() As String
[Step] = "Step"
End Property

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

Public Property Get [Stop]() As String
[Stop] = "Stop"
End Property

Public Property Get [String]() As String
[String] = "String"
End Property

Public Property Get [Sub]() As String
[Sub] = "Sub"
End Property

Rem Contextual in VB6
Public Property Get [Text]() As String
[Text] = "Text"
End Property

Public Property Get [Then]() As String
[Then] = "Then"
End Property

Public Property Get [To]() As String
[To] = "To"
End Property

Public Property Get [True]() As String
[True] = "True"
End Property

Public Property Get [Type]() As String
[Type] = "Type"
End Property

Public Property Get [TypeOf]() As String
[TypeOf] = "TypeOf"
End Property

Public Property Get [Unlock]() As String
[Unlock] = "Unlock"
End Property

Public Property Get [Until]() As String
[Until] = "Until"
End Property

Public Property Get [Variant]() As String
[Variant] = "Variant"
End Property

Public Property Get [Void]() As String
Rem Intentionally blank
End Property

Public Property Get [Wend]() As String
[Wend] = "Wend"
End Property

Public Property Get [While]() As String
[While] = "While"
End Property

Rem Contextual in VB6
Public Property Get [Width]() As String
[Width] = "Width"
End Property

Public Property Get [With]() As String
[With] = "With"
End Property

Public Property Get [WithEvents]() As String
[WithEvents] = "WithEvents"
End Property

Public Property Get [Write]() As String
[Write] = "Write"
End Property

Public Property Get [Xor]() As String
[Xor] = "Xor"
End Property
End Class

Public Class WhileConstruct
Option Explicit
Implements IStmt

Private Body_ As KeyedList

Public Condition 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 = snWhile
End Property

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

Public Class WidthConstruct
Option Explicit
Implements IStmt

Public FileNumber As IExpression
Public Value As IExpression

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

Public Class WithConstruct
Option Explicit
Implements IStmt

Private Body_ As KeyedList

Public PinObject 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 = snWith
End Property

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

Public Class WriteConstruct
Option Explicit
Implements IStmt

Private Output_ As KeyedList

Public FileNumber As IExpression

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

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

Public Property Get Output() As KeyedList
Set Output = Output_
End Property
End Class

Public Module ForwardCompatibility
Option Explicit

Public Const vbLongLong = 20
Public Const vbLongPtr = 37

Public Enum [LongPtr]
Zero
End Enum
End Module

Private Module Globals
Option Explicit

Public NameBank As New NameBank
Public V As New Vocabulary
Public x As New Messages

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

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

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

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

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

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

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

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

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

Case kwByte
SizeOf = 1

Case kwLong, kwSingle
SizeOf = 4

Case kwLongLong, kwCurrency, kwDouble, kwDate
SizeOf = 8

Case cxDecimal
SizeOf = 16

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

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

Case Else
Debug.Assert False
End Select
End Function

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

If LHS = RHS Then Exit Function

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

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

Case opPow
Precedence = 18

Case opAddressOf, opNew, opByVal
Precedence = 17

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

Case opLSh, opRSh, opURSh
Precedence = 15

Case opMul, opDiv
Precedence = 14

Case opIntDiv
Precedence = 13

Case opMod
Precedence = 12

Case opSum, opSubt
Precedence = 11

Case opConcat
Precedence = 10

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

Case opNot
Precedence = 8

Case opAnd, opAndAlso
Precedence = 7

Case opOr, opOrElse
Precedence = 6

Case opXor
Precedence = 5

Case opEqv
Precedence = 4

Case opImp
Precedence = 3

Case opNamed
Precedence = 2

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

Case Else
Debug.Assert False
End Select
End Function

Public Sub EnsureIdExists(ByVal Token As Token)
Dim Name As String

Debug.Assert Token.Kind <> tkIdentifier

With NameBank
Name = .Item(Token)
If Not .Ids.Exists(Name) Then .Ids.Add Name, Name
Token.Code = .Ids.IndexOf(Name) + .Keywords.Count + .Contextuals.Count
Token.Kind = tkIdentifier
End With
End Sub
End Module

Public Module Program
Option Explicit
Option Compare Binary

Private Const SPAN_STRING = ""
Private Const SPAN_KEYWORD = ""
Private Const SPAN_COMMENT = ""

Public Sub Main()
Dim Source As SourceFile
Dim Parser As Parser
Dim Builder As FileTextBuilder
Dim Revert As Reverter

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

Set Parser = New Parser
Parser.Parse Source

Set Builder = New FileTextBuilder
Builder.FilePath = Source.Path & ".out"

Set Revert = New Reverter
Set Revert.Builder = Builder
Revert.Transpile Source
Exit Sub

ErrHandler:
MsgBox Err.Description, vbCritical, "Parser Error"
End Sub

Public Sub PrettyPrint()
Dim Text As String
Dim Token As Token
Dim Parser As Parser
Dim Source As SourceFile

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

Rem File path for the source code is passed as a command-line argument.
Set Source = New SourceFile
Dim FilePath As String = Command$
Source.Path = FilePath

Set Parser = New Parser
Set Parser.SourceFile = Source

Rem Output file will have the same name as the input file, but with an .HTML extension.
Dim Index As Integer = InStrRev(FilePath, ".")
If Index <> 0 Then FilePath = Left$(FilePath, Index - 1)

FilePath &= ".html"
Dim HtmlFile As Integer = FreeFile
Open FilePath For Output Access Write As #HtmlFile

Dim Nbsp As Boolean = True

Do
Set Token = Parser.NextToken(ForPrint:=True)

If Nbsp Then
For Index = 1 To Token.Spaces
Print #HtmlFile, "    ";
Next
Else
Print #HtmlFile, Space$(Token.Spaces);
End If

Select Case Token.Kind
Case tkComment
Print #HtmlFile, SPAN_COMMENT; EncodeHtml(Token.Text); " "
Nbsp = True

Case tkIdentifier
Print #HtmlFile, NameBank(Token);
Nbsp = False

Case tkIntegerNumber, tkFloatNumber, tkSciNumber
If Left$(Token.Text, 1) = "-" Then Print #HtmlFile, "-";
Print #HtmlFile, Mid$(Token.Text, 2);
Nbsp = False

Case tkEscapedIdentifier
Print #HtmlFile, "["; NameBank(Token.Text); "]";
Nbsp = False

Case tkKeyword
Print #HtmlFile, SPAN_KEYWORD; NameBank(Token); "";
Nbsp = False

Case tkBinaryNumber
If Left$(Token.Text, 1) = "-" Then Print #HtmlFile, "-";
Print #HtmlFile, "&B"; Mid$(Token.Text, 2);

Case tkOctalNumber
If Left$(Token.Text, 1) = "-" Then Print #HtmlFile, "-";
Print #HtmlFile, "&O"; Mid$(Token.Text, 2);

Case tkHexaNumber
If Left$(Token.Text, 1) = "-" Then Print #HtmlFile, "-";
Print #HtmlFile, "&H"; UCase$(Mid$(Token.Text, 2));

Case tkFileHandle
Print #HtmlFile, "#"; Token.Text;

Case tkString
Text = Token.Text
Text = Replace(Token.Text, """", """""")
Text = EncodeHtml(Text)
Print #HtmlFile, SPAN_STRING; """"; Text; """";

Case tkDateTime
Print #HtmlFile, "#"; Token.Text; "#";

Case tkOperator
If IsLetter(AscW(NameBank(Token))) Then
Print #HtmlFile, SPAN_KEYWORD; NameBank(Token); "";

ElseIf Left$(NameBank(Token), 1) = "" ~Then
Print #HtmlFile, Mid$(NameBank(Token), 2);

Else
Print #HtmlFile, EncodeHtml(NameBank(Token));
End If

Case tkLeftParenthesis
Print #HtmlFile, "(";
Nbsp = False

Case tkRightParenthesis
Print #HtmlFile, ")";
Nbsp = False

Case tkListSeparator
Print #HtmlFile, ",";
Nbsp = False

Case tkSoftLineBreak
Print #HtmlFile, ":";
Nbsp = False

Case tkPrintSeparator
Print #HtmlFile, ";";
Nbsp = False

Case tkLineContinuation
Print #HtmlFile, " _ "
Nbsp = True

Case tkHardLineBreak
Print #HtmlFile, " "
Nbsp = True

Case tkDirective
Print #HtmlFile, "#"; Token.Text;
Nbsp = False

Case tkEndOfStream
Exit Do
End Select

If Token.Suffix <> vbNullChar Then Print #HtmlFile, Token.Suffix;
Loop

CloseIt:
Close #HtmlFile
Rem This is equivalent to a Throw in a Catch.
If Err.Number Then Err.Raise Err.Number
End Sub

Private Function EncodeHtml(ByVal Text As String) As String
Text = Replace(Text, "&", "&")
Text = Replace(Text, "<", "<")
Text = Replace(Text, ">", ">")
EncodeHtml = Text
End Function
End Module

Public Module StringCentral
Option Explicit

Private Const NO_OF_COLS = 5

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

Private CodePoints_() As Integer
Private IsInit_ As Boolean

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

Public Function ToUpper(ByVal Text As String) As String
Dim Cp As Integer
Dim Pos As Long

Dim Result As String = Text

For Pos = 1 To Len(Text)
Dim Ch As String * 1 = Mid$(Result, Pos, 1)

Select Case Ch
Case "A" To "Z"
Exit Select

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

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

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

ToUpper = Result
End Function

Public Function ToLower(ByVal Text As String) As String
Dim Cp As Integer
Dim Pos As Long

Dim Result As String = Text

For Pos = 1 To Len(Text)
Dim Ch As String * 1 = Mid$(Result, Pos, 1)

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

Case "a" To "z"
Exit Select

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

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

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

ToLower = Result
End Function

Public Function ToTitle(ByVal Text As String) As String
Dim Pos As Long
Dim Index As Long

Dim Result As String = Text
Dim ToUp As Boolean = True

For Pos = 1 To Len(Text)
Dim Ch As String * 1 = Mid$(Result, Pos, 1)
Dim Cp As Integer = AscW(Ch)

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

Select Case Ch
Case "A" To "Z"
Exit Select

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

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

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

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

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

ToTitle = Result
End Function

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

Dim ResultIndex As Long = FirstIndex - 1
Dim RightPoint As Long = UBound(SourceArray) - Step + 1 + FirstIndex
Dim LeftPoint As Long = FirstIndex

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

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

Case Is > Target
RightPoint = MiddlePoint - Step

Case Else
ResultIndex = MiddlePoint
Exit Do
End Select
Loop

BinarySearch = ResultIndex
End Function

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

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

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

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

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

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

Private Module VariantEnumeratorHome
Option Explicit

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

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

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

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

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

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

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

Rem Return it.
AddRefEntry = This.Count
End Function

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

Rem Return it.
ReleaseEntry = This.Count

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

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

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

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

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

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

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

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

Rem Get the legal object.
Set Res = Obj

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

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

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

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