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

Let's build a transpiler! Part 36

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

To bytes and back

VB6 has a nice feature: It has seamless conversion between string and array of bytes and vice-versa.
From string to bytes:

Dim Bytes() As Byte
Bytes = "Hi, world!"

'Bytes now is:
'Bytes(0) ->   72 = H
'Bytes(1) ->    0
'Bytes(2) ->  105 = i
'Bytes(3) ->    0
'Bytes(4) ->   44 = ,
'Bytes(5) ->    0
'Bytes(6) ->   32 = <space>
'Bytes(7) ->    0
'Bytes(8) ->  119 = w
'Bytes(9) ->    0
'Bytes(10) -> 111 = o
'Bytes(11) ->   0
'Bytes(12) -> 114 = r
'Bytes(13) ->   0
'Bytes(14) -> 108 = l
'Bytes(15) ->   0
'Bytes(16) -> 100 = d
'Bytes(17) ->   0
'Bytes(18) ->  33 = !
'Bytes(19) ->   0

As ou can see, each character is composed of two bytes / an Integer.
From bytes to string:

Dim S As String
S = Bytes
Debug.Print s 'It prints "Hi, world!"

Even though technically a VB String is null-terminated, this null terminator is not included in the byte array.

Back to business

A couple of weeks back I said we would convert the entire project to VBScript again.
In doing that I stumbled upon "new" VBScript's restrictions:
Due to this last point, I decided to get rid of all Validators. Not only TypeOf does not exist in VBScript, but I had some issues in validating Empty values that were supposed to be Strings.

Another issue related to not being able to use interfaces is that CallConstruct now cannot return ekIndexer through its IExpression_Kind property and snCall through IStmt_Kind.
It does not implement any interface anymore, but we still need to know which expression or statement we are dealing with, so these two Kind properties were merged into one and the ekIndexer value was adjusted to have the same value as snCall. So it does not matter now if the Kind property is being called to some statement checking or expression checking; it will work for both.

Everything you wanted to know about not providing optional parameters but was afraid to ask

Last time we converted our project to a script, we provided every optional argument. This time we will do something different: We will move every optional parameter to a position before the mandatory ones.
It means we will transform this:

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

Into this:

Private Function NewToken(ByVal Code, ByVal Text, ByVal Suffix, ByVal Kind)
Then we'll trace every function call and will not provide those optional arguments!
If the call was "Set GetToken = NewToken(tkEndOfStream)" we'll change it to "Set GetToken = NewToken(, , , tkEndOfStream)".
Now, when the call is made during runtime, VBScript will fill these blanks with an error value. We can detect it using the function below:

Function IsMissing(Value)
IsMissing = VarType(Value) = vbError
End Function

Then, inside the called function we detect that the parameter is missing and provide a default value to it:

If IsMissing(Suffix) Then Suffix = vbNullChar
If you remember, our KeyedList class had two similar methods: Add, that receives a value and an optional key, and AddKeyValue, that receives a mandatory key then a mandatory value.
As we had to change Add due to its optional parameter, AddKeyValue became redundant, so I removed it.

Moving optional parameters before mandatory ones just works for procedures having at least one mandatory argument. If all it has is one optional argument, we are back to providing a default value at its call site.

Which brings us to our next topic: NextToken has only one parameter, and is an optional one. And it is called thousands of times without providing it.
Actually, it is only provided when pretty-printing. If there's something I am not going to do is chase every NextToken call to provide a useless argument there.
What I did instead was to change NextToken's name to InternalNextToken and made it Private.
Then I created a new Public NextToken that calls InternalGetToken providing it a dummy argument.
Then I created a new NextTokenForPrint that properly calls NextToken and changed the only call to NextToken in PrettyPrint to it instead.
Bullet adverted. Phew!

For Each try a fail

Back to KeyedList, I've found out there's no fraking way to implement IEnumVARIANT in VBScript.
I was not happy. No happy at all. I've spent too much time trying to make it work but came up empty-handed... Lesson learned I guess.
I had to resort to gathering all KeyedList's elements in an array, return the array through the NewEnum function, and call NewEnum explicitly in every For Each throughout the code.

An argument by any other name

I think named arguments are good to document code and did not like to have them removed the first time I came up with the script.
This time I'm doing something different: I've created a Named function that accepts a text and a value and returns that value.
So I used the text part to document the reason for the argument being provided. Even though it is a pretty useless function, I'd liked it:

Set Handle_ = .OpenTextFile(Value, ForWriting, Named("Create:=", True), Named("Format:=Unicode", True))

GoTo considered... annoying

As we improved our code, I had reintroduced a couple of GoTos, but now have to get rid of them again.
You will see that I factored out the common code into a SubGoTo1 function and a SubGoTo2 sub. I don't think the outcome is better, though.
I still pretty much prefer the original code.

Vocabulary class

No much to see here. Vocabulary was a module and now is a class.
Why I did it? Well, suppose Vocabulary's words are not hardcoded into it but instead are read from a configuration file.
It means that, in theory, we could parse and transpile keywords that are not English, but maybe... Spanish? Welsh? Latin? Oh, the possibilities...

VBScript bugs

You already know about default methods and that they are supported by VBScript. Unfortunately, they do not work as they should.
If we have a class with a default property and are directly using an instance of it, everything is OK. This works:

Option Explicit

Class Greeter
Public Default Property Get SayHi(Name)
SayHi = "Hi, " & Name
End Property
End Class

Dim Greet
Set Greet = New Greeter
MsgBox Greet("Biasic")

But if we get the instance in a "second hand" way, then we get a "Wrong number of arguments or invalid property assignment" error message:

Class GreeterBearer
Private Greeter_

Private Sub Class_Initialize()
Set Greeter_ = New Greeter
End Sub

Public Property Get Greeter()
Set Greeter = Greeter_
End Property
End Class

Dim Bearer = New GreeterBearer
MsgBox Bearer.Greeter("Biasic") '<-It does not work!

My solution was to delete every Property Get whose only purpose was to mimic read-only access to an internal variable and expose that variable as public instead.
Not pretty, but worked.

The second issue is that I could not make VBScript understand that while class Parser does have a Scanner property, when I'm Newing Scanner, I meant "Scanner" to be the class, not the property (that is not Newable anyways...)
When I ran the script I was "greeted" twice by the error "Class not defined: Scanner". It confused the hell out of me for no less than three fraking whole days!
That's why I renamed the Scanner class to Tokenizer. Life is too short...

Heh... What about your bugs?

I was almost forgetting... We had a bug that I workarounded it by appending a line break at the end of the source file.
To do the same in VBScript, we would need to 1) open the file for reading, 2) read all the text, and 3) check if it ended with a line break.
If it didn't, we'd 4) append a line break to the text we just read, 5) close the file, 6) open for writing, 7) write the new text over the old one, 8) close the file, and 9) open it for reading again so we can start parsing it... It does not seem like a workaround anymore.

Fortunately, the fix is simple: We just add tkEndOfStream as an accepted line break in IsBreak function.
That's it. No need to fuss with source files anymore.

Now you know my adventures and perils in translating VB6 to VBScript.
Enjoy the new version of the script below.

Next week we'll parse attributes.

Andrej Biasic
2021-05-26

Option Explicit

Const VbGet = 2
Const VbLet = 4
Const VbSet = 8

Const ForReading = 1
Const ForWriting = 2

Function vbBack()
vbBack = ChrW(8)
End Function

'Enum ContinueWhat
Const cwDo = 0
Const cwFor = 1
Const cwWhile = 2

'Enum DoWhat
Const dtNone = 0
Const dtDoLoop = 1
Const dtDoWhileLoop = 2
Const dtDoUntilLoop = 3
Const dtDoLoopWhile = 4
Const dtDoLoopUntil = 5

'Enum ExitWhat
Const ewDo = 0
Const ewFor = 1
Const ewFunction = 2
Const ewProperty = 3
Const ewSelect = 4
Const ewSub = 5
Const ewWhile = 6

'Enum ExpressionKind
Const ekLiteral = 0
Const ekSymbol = 6
Const ekFileHandle = 2
Const ekTuple = 3
Const ekUnaryExpr = 4
Const ekBinaryExpr = 5
Const ekIndexer = 1

'Enum StmtNumbers
Const snCall = 1
Const snClose = 2
Const snConst = 3
Const snContinue = 4
Const snDebug = 5
Const snDim = 6
Const snDo = 7
Const snEnd = 8
Const snErase = 9
Const snExit = 10
Const snFor = 11
Const snForEach = 12
Const snGet = 13
Const snGoSub = 14
Const snGoTo = 15
Const snIf = 16
Const snInput = 17
Const snLabel = 18
Const snLet = 19
Const snLineNumber = 20
Const snLock = 21
Const snLSet = 22
Const snName = 23
Const snOnError = 24
Const snOnComputed = 25
Const snOpen = 26
Const snPrint = 27
Const snPut = 28
Const snRaiseEvent = 29
Const snReDim = 30
Const snReset = 31
Const snResume = 32
Const snReturn = 33
Const snRSet = 34
Const snSeek = 35
Const snSelect = 36
Const snSet = 37
Const snStop = 38
Const snUnlock = 39
Const snWhile = 40
Const snWidth = 41
Const snWith = 42
Const snWrite = 43

'Enum FileModes
Const fmRandom = 0
Const fmAppend = 1
Const fmBinary = 2
Const fmInput = 3
Const fmOutput = 4

'Enum FileAccesses
Const faNone = 0
Const faRead = 1
Const faWrite = 2
Const faReadWrite = 3

'Enum FileLocks
Const flShared = 0
Const flRead = 1
Const flWrite = 2
Const flReadWrite = 3

'Enum Accessibility
Const acLocal = 0
Const acPublic = 1
Const acPrivate = 2
Const acFriend = 3

'Enum SignatureKind
Const skSub = 1
Const skFunction = 2
Const skPropertyGet = 3
Const skPropertyLet = 4
Const skPropertySet = 5
Const skDeclare = 6
Const skEvent = 7
Const skTuple = 8

'Enum NarrowContext
Const ncNone = 0
Const ncOption = 1
Const ncOptionCompare = 2
Const ncOn = 3
Const ncDeclare = 4
Const ncDeclareLib = 5
Const ncDeclareAlias = 6
Const ncForNext = 7
Const ncForTo = 8
Const ncOpen01 = 9
Const ncOpen02 = 10
Const ncOpen03 = 11
Const ncOpen04 = 12
Const ncOpen05 = 13
Const ncOpen06 = 14
Const ncOpen07 = 15
Const ncOpen08 = 16
Const ncOpen09 = 17
Const ncOpen10 = 18
Const ncOpen11 = 19

'Enum TokenKind
Const tkWhiteSpace = 0
Const tkComment = 1
Const tkIdentifier = 2
Const tkEscapedIdentifier = 3
Const tkKeyword = 4
Const tkIntegerNumber = 5
Const tkFloatNumber = 6
Const tkSciNumber = 7
Const tkBinaryNumber = 8
Const tkOctalNumber = 9
Const tkHexaNumber = 10
Const tkFileHandle = 11
Const tkString = 12
Const tkDateTime = 13
Const tkOperator = 14
Const tkLeftParenthesis = 15
Const tkRightParenthesis = 16
Const tkHardLineBreak = 17
Const tkSoftLineBreak = 18
Const tkLineContinuation = 19
Const tkListSeparator = 20
Const tkPrintSeparator = 21
Const tkDirective = 22
Const tkEndOfStream = 23

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

'Enum ContextualNumbers
Const cxAccess = 113
Const cxAlias = 114
Const cxAppend = 115
Const cxBase = 116
Const cxBinary = 117
Const cxCompare = 118
Const cxDecimal = 119
Const cxError = 120
Const cxExplicit = 121
Const cxLen = 122
Const cxLib = 123
Const cxLine = 124
Const cxLock = 125
Const cxName = 126
Const cxObject = 127
Const cxOutput = 128
Const cxProperty = 129
Const cxPtrSafe = 130
Const cxRandom = 131
Const cxRead = 132
Const cxReset = 133
Const cxShared = 134
Const cxSpc = 135
Const cxStep = 136
Const cxTab = 137
Const cxText = 138
Const cxWidth = 139

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

Class BinaryExpression
Public LHS
Public Operator
Public RHS

Private Sub Class_Initialize()
Set LHS = Nothing
Set Operator = Nothing
Set RHS = Nothing
End Sub

Public Property Get Kind()
Kind = ekBinaryExpr
End Property
End Class

Class CallConstruct
Public Arguments
Public LHS

Private Sub Class_Initialize()
Set Arguments = New KeyedList
Set LHS = Nothing
End Sub

Public Property Get Kind()
Kind = ekIndexer
End Property
End Class

Class CaseConstruct
Public Conditions
Public Body

Private Sub Class_Initialize()
Set Conditions = New KeyedList
Set Body = New KeyedList
End Sub
End Class

Class CloseConstruct
Public FileNumbers

Private Sub Class_Initialize()
Set FileNumbers = New KeyedList
End Sub

Public Property Get Kind()
Kind = snClose
End Property
End Class

Class ConstConstruct
Public Access
Public Id
Public DataType
Public Value

Private Sub Class_Initialize()
Set Id = Nothing
Set DataType = Nothing
Set Value = Nothing
End Sub

Public Property Get Kind()
Kind = snConst
End Property
End Class

Class ContinueConstruct
Public What

Private Property Get Kind()
Kind = snContinue
End Property
End Class

Class DataType
Public Id
Public IsArray
Public FixedLength

Private Sub Class_Initialize()
Set Id = Nothing
Set FixedLength = Nothing
End Sub
End Class

Class DeclareConstruct
Public Parameters
Public Access
Public IsSub
Public Id
Public IsCDecl
Public LibName
Public AliasName
Public DataType

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

Set Id = Nothing
Set LibName = Nothing
Set AliasName = Nothing
Set DataType = Nothing
End Sub
End Class

Const LAST_INDEX = 25
Class DefType
Private A_Z_
Private Letters_
Private DfType_

Private Sub Class_Initialize()
Letters_ = Array(Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, _
Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, _
Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)

Set DfType_ = New Token
DfType_.Kind = tkKeyword
DfType_.Code = kwVariant
End Sub

Public Default Property Get Item(ByVal Letter)
Dim Index: Index = ToIndex(Letter)

If A_Z_ Then
Set Item = Letters_(0)

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

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

Public Sub SetRange(ByVal FirstLetter, ByVal LastLetter, ByVal VariableType)
Dim Letter

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

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

A_Z_ = First = 0 And Last = LAST_INDEX

Dim 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
MsgBox "Should not happen (1)"
Err.Raise 5
End Select

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

Set Letters_(Letter) = Token
Next
End Sub

Private Function ToIndex(ByVal Letter)
Const CAPITAL_A = 65
Const CAPITAL_Z = 90
Const SMALL_A = 97

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

Class DoConstruct
Public Body
Public Condition
Public DoType

Private Sub Class_Initialize()
Set Body = New KeyedList
Set Condition = Nothing
End Sub

Public Property Get Kind()
Kind = snDo
End Property
End Class

Class EndConstruct
Public Property Get Kind()
Kind = snEnd
End Property
End Class

Class Entity
Public Consts
Public Enums
Public Declares
Public Events
Public Impls
Public Vars
Public Types
Public Subs
Public Functions
Public Properties
Public DefTypes
Public OptionBase
Public OptionCompare
Public OptionExplicit
Public IsClass
Public Accessibility
Public Id

Private Sub Class_Initialize()
OptionBase = 0

Set Consts = New KeyedList
Consts.CompareMode = vbTextCompare

Set Enums = New KeyedList
Enums.CompareMode = vbTextCompare

Set Declares = New KeyedList
Declares.CompareMode = vbTextCompare

Set Events = New KeyedList
Events.CompareMode = vbTextCompare

Set Impls = New KeyedList
Impls.CompareMode = vbTextCompare

Set Vars = New KeyedList
Vars.CompareMode = vbTextCompare

Set Types = New KeyedList
Types.CompareMode = vbTextCompare

Set Subs = New KeyedList
Subs.CompareMode = vbTextCompare

Set Functions = New KeyedList
Functions.CompareMode = vbTextCompare

Set Properties = New KeyedList
Properties.CompareMode = vbTextCompare

Set DefTypes = New DefType
Set Id = Nothing
End Sub
End Class

Class EnumConstruct
Public Enumerands
Public Access
Public Id

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

Set Id = Nothing
End Sub
End Class

Class EnumerandConstruct
Public Access
Public Id
Public Value

Private Sub Class_Initialize()
Set Id = Nothing
Set Value = Nothing
End Sub
End Class

Class EraseConstruct
Public Vars

Private Sub Class_Initialize()
Set Vars = New KeyedList
End Sub

Public Property Get Kind()
Kind = snErase
End Property
End Class

Class EventConstruct
Public Parameters
Public Id

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

Set Id = Nothing
End Sub

Public Property Get Access()
Access = acPublic
End Property
End Class

Class ExitConstruct
Public What

Public Property Get Kind()
Kind = snExit
End Property
End Class

Class Expressionist
Private LastToken_

Public CanHaveTo
Public FullMode

Private Sub Class_Initialize()
Set LastToken_ = Nothing
End Sub

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

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

Private Function Pop(ByVal Stack)
Dim Index: Index = Stack.Count
Set Pop = Stack(Index)
Stack.Remove Index
End Function

Rem Adapted from https://stackoverflow.com/questions/16380234/handling-extra-operators-in-shunting-yard/16392115#16392115
Public Function GetExpression(ByVal Token, ByVal Parser)
Dim HadTo, Cp, Sym, Lit, Op, Handle, Args

If IsMissing(Token) Then Set Token = Nothing

Dim OpStack: Set OpStack = New KeyedList
Dim OutStack: Set OutStack = New KeyedList
Dim WantOperand: WantOperand = 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 opSum
Token.Code = opId

Case opSubt
Token.Code = opNeg

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

Case Else
Exit Do
End Select

Set Op = NewOperator(Token)
OpStack.Add , Op

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

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

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

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

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

Case kwInput, kwSeek
Set Sym = New Symbol
Set Sym.Value = Token
OutStack.Add , Sym

Case kwByVal
Token.Kind = tkOperator
Token.Code = opByVal
If SubGoTo1(Token, OpStack, OutStack) Then Exit Do
WantOperand = True

Case Else
Exit Do
End Select

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

Exit Do
End If

Select Case Token.Kind
Case tkOperator
If SubGoTo1(Token, OpStack, OutStack) Then Exit Do
WantOperand = True

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

Move Op, OpStack, OutStack
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 Or 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 Fail Token, Msg036, Msg057
OutStack.Add , Args

Case Else
Exit Do
End Select
End If

Set Token = Nothing
Loop

Set LastToken_ = Token

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

Move Op, OpStack, OutStack
Loop

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

Private Function SubGoTo1(ByVal Token, ByVal OpStack, ByVal OutStack)
Rem Unary and compound operators
Select Case Token.Code
Case opAddressOf, opNew, opNot, opTypeOf
Parser.Fail , Token, Msg065

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

Dim Op2: Set Op2 = NewOperator(Token)

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

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

OpStack.Add , Op2
End Function

Private Sub Move(ByVal Op, ByVal OpStack, ByVal OutStack)
Dim Elem

If IsMissing(Op) Then Set Op = Nothing
Dim IExpr: Set IExpr = Nothing
Dim Uni: Set Uni = Nothing
Dim Bin: Set Bin = Nothing
Dim Exec: Set Exec = Nothing
Dim Tup: Set Tup = Nothing

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

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

For Each Elem In Tup.Elements.NewEnum
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 Token, ByVal LookAhead, ByVal Parser)
Dim Done, Sym

If IsMissing(Token) Then Set Token = Nothing
If IsMissing(LookAhead) Then Set LookAhead = Nothing
Dim Result: Set Result = Nothing
Dim Name: Set Name = Nothing
Dim Expr: Set Expr = Nothing
Dim Asg: Set Asg = Nothing
Dim Exec: Set Exec = Nothing
Dim Bin: Set Bin = Nothing
Dim Xp: Set Xp = New Expressionist

If Token Is Nothing Then Set Token = Parser.NextToken

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

Set Sym = New Symbol
Set Sym.Value = Token
Set Uni.Value = Sym
Set Name = Uni
Else
Stopp 2
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(Token, Exec.Arguments, Parser)
Set Result = Exec

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

Set Token = Parser.NextToken
If Token.Kind <> tkIdentifier And Token.Kind <> tkEscapedIdentifier 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(Token, Exec.Arguments, Parser)
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
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(Token, Exec.Arguments, Parser)
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(Token, Exec.Arguments, Parser)
Set Result = Exec

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

Case kwEmpty, kwFalse, kwMe, kwNothing, kwNull, kwTrue
Set Exec = New CallConstruct
Set Exec.LHS = Name
Set Token = CollectArgs(Token, Exec.Arguments, Parser)
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(Token, Exec.Arguments, Parser)
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

Public Function CollectArgs(ByVal Token, ByVal Args, ByVal Parser)
If IsMissing(Token) Then Set Token = Nothing
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

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

Dim Lit: Set Lit = New Literal
Set Lit.Value = Token

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

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

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

Case tkListSeparator
Dim Tkn: 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 Then Exit Do
If Token.Kind <> tkListSeparator Then Exit Do
Set Token = Nothing
Loop

Set CollectArgs = Token
End Function
End Class

Class FileHandle
Public Value

Private Sub Class_Initialize()
Set Value = Nothing
End Sub

Public Property Get Kind()
Kind = ekFileHandle
End Property
End Class

Class FileTextBuilder
Private IsNewLine_
Private Indent_
Private Handle_

Public Property Let FilePath(ByVal Value)
With CreateObject("Scripting.FileSystemObject")
Set Handle_ = .OpenTextFile(Value, ForWriting, Named("Create:=", True), Named("Format:=Unicode", True))
End With
End Property

Private Sub Class_Terminate()
Handle_.Access
End Sub

Public Sub Append(ByVal Text)
If IsNewLine_ Then
Handle_.WriteLine
If Indent_ > 0 Then Handle_.Access Access(Indent_, vbTab)
End If

IsNewLine_ = False
Handle_.Access Text
End Sub

Public Sub AppendLn(ByVal Text)
If Text = "" Then
If IsNewLine_ Then Handle_.WriteLine
Else
Append Text
End If

IsNewLine_ = True
End Sub

Public Sub Deindent()
Indent_ = Indent_ - 1
End Sub

Public Sub Indent()
Indent_ = Indent_ + 1
End Sub
End Class

Class ForConstruct
Public Body
Public Counter
Public StartValue
Public EndValue
Public Increment

Private Sub Class_Initialize()
Set Body = New KeyedList
Set Counter = Nothing
Set StartValue = Nothing
Set EndValue = Nothing
Set Increment = Nothing
End Sub

Public Property Get Kind()
Kind = snFor
End Property
End Class

Class ForEachConstruct
Public Body
Public Element
Public Group

Private Sub Class_Initialize()
Set Body = New KeyedList
Set Element = Nothing
Set Group = Nothing
End Sub

Public Property Get Kind()
Kind = snForEach
End Property
End Class

Class FunctionConstruct
Public Parameters
Public Body
Public Access
Public IsStatic
Public IsDefault
Public IsIterator
Public Id
Public DataType

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

Set Body = New KeyedList
Set Id = Nothing
Set DataType = Nothing
End Sub
End Class

Class GetConstruct
Public FileNumber
Public RecNumber
Public Var

Private Sub Class_Initialize()
Set FileNumber = Nothing
Set RecNumber = Nothing
Set Var = Nothing
End Sub

Public Property Get Kind()
Kind = snGet
End Property
End Class

Class GoSubConstruct
Public Target

Private Sub Class_Initialize()
Set Target = Nothing
End Sub

Public Property Get Kind()
Kind = snGoSub
End Property
End Class

Class GoToConstruct
Public Target

Private Sub Class_Initialize()
Set Target = Nothing
End Sub

Public Property Get Kind()
Kind = snGoTo
End Property
End Class

Class Identifier
Private Name_
Private Project_

Private Sub Class_Initialize()
Set Name_ = Nothing
Set Project_ = Nothing
End Sub

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

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

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

Class IfArm
Public Body
Public Condition

Private Sub Class_Initialize()
Set Body = New KeyedList
Set Condition = Nothing
End Sub
End Class

Class IfConstruct
Public Arms
Public ElseBody

Private Sub Class_Initialize()
Set Arms = New KeyedList
Set ElseBody = New KeyedList
End Sub

Public Property Get Kind()
Kind = snIf
End Property
End Class

Class ImplementsConstruct
Private Id_

Private Sub Class_Initialize()
Set Id_ = New Identifier
End Sub

Public Property Get Id()
Set Id = Id_
End Property
End Class

Class InputConstruct
Public Vars
Public FileNumber

Private Sub Class_Initialize()
Set Vars = New KeyedList
Set FileNumber = Nothing
End Sub

Public Property Get Kind()
Kind = snInput
End Property
End Class

Class KeyedList
Private ReadOnly_
Private Base_
Private Id_
Private Count_
Private Root_
Private Last_
Private Validator_
Private CompareMode_

Private Sub Class_Initialize()
Id_ = &H80000000
Base = 1

Set Root_ = Nothing
Set Last_ = Nothing
Set Validator_ = Nothing
End Sub

Private Sub Class_Terminate()
ReadOnly_ = False
Clear
End Sub

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

Dim NewKey

If ReadOnly_ Then Err.Raise 5
If Not Validator_ Is Nothing Then: If Not Validator_.Validate(Item) Then Err.Raise 13

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

Case vbError
NewKey = Id & Hex(Id_)
Id_ = Id_ + 1

Case Else
Err.Raise 13
End Select

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

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

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

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

Count_ = Count_ + 1
End Sub

Public Property Get Count()
Count = Count_
End Property

Public Default Property Get Item(ByVal Index)
Dim Node: 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)
Exists = Not FindNode(Key) Is Nothing
End Property

Public Property Get Base()
Base = Base_
End Property

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

Public Property Get CompareMode()
CompareMode = CompareMode_
End Property

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

Public Sub Remove(ByVal Index)
Dim Found, Idx, Key

If ReadOnly_ Then Err.Raise 5
Dim PrvNode: Set PrvNode= Nothing
Dim CurNode: Set CurNode = Root_

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

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

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

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

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

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

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

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

Public Function NewEnum()
Dim Result, Node, Idx

If Count_ = 0 Then
Result = Array()
Else
ReDim Result(Count_ - 1)
Set Node = Root_
Idx = 0

Do Until Node Is Nothing
If IsObject(Node.Value) Then Set Result(Idx) = Node.Value Else Result(Idx) = Node.Value
Idx = Idx + 1
Set Node = Node.NextNode
Loop
End If

NewEnum = Result
End Function

Public Sub Clear()
Dim NextNode

If ReadOnly_ Then Err.Raise 5
Dim CurrNode: 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)
Dim Idx, Node

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

If Idx >= 0 Then
Set Node = Root_

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

Set FindNode = Node
End Function

Private Function FindKey(ByVal Key)
Dim Node: 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

Set FindKey = Nothing
End Function

Public Property Get IndexOf(ByVal Key)
Dim Count

Dim Node: Set Node = Root_

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

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

Public Sub AddValues(Values)
Dim Value

For Each Value In Values
Add Value
Next
End Sub

Public Sub AddKVPairs(KeyValuePairs)
Dim Idx

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

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

Public Property Get ReadOnly()
ReadOnly = ReadOnly_
End Property

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

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

Class KLNode
Public NextNode
Public Key
Public Value

Private Sub Class_Initialize()
Set NextNode = Nothing
End Sub
End Class

Class LabelConstruct
Public Id

Private Sub Class_Initialize()
Set Id = Nothing
End Sub

Public Property Get Kind()
Kind = snLabel
End Property
End Class

Class LetConstruct
Public Name
Public Operator
Public Value

Private Sub Class_Initialize()
Set Name = Nothing
Set Operator = Nothing
Set Value = Nothing
End Sub

Public Property Get Kind()
Kind = snLet
End Property
End Class

Class LineNumberConstruct
Public Value

Private Sub Class_Initialize()
Set Value = Nothing
End Sub

Public Property Get Kind()
Kind = snLineNumber
End Property
End Class

Class Literal
Public Value

Private Sub Class_Initialize()
Set Value = Nothing
End Sub

Public Property Get Kind()
Kind = ekLiteral
End Property
End Class

Class LockConstruct
Public FileNumber
Public RecordRange

Private Sub Class_Initialize()
Set FileNumber = Nothing
Set RecordRange = Nothing
End Sub

Public Property Get Kind()
Kind = snLock
End Property
End Class

Class LSetConstruct
Public Name
Public Value

Private Sub Class_Initialize()
Set Name = Nothing
Set Value = Nothing
End Sub

Public Property Get Kind()
Kind = snLSet
End Property
End Class

Class NameBank
Public Ids
Public Keywords
Public Operators
Public Contextuals

Private Sub Class_Initialize()
Dim Value

Set Ids = New KeyedList
Ids.CompareMode = vbTextCompare

Set Keywords = New KeyedList
Keywords.CompareMode = vbTextCompare

Rem Keyword order must follow the Enum's one.
Dim Values: 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)

Access Each Value In Values
Keywords.Add Value, Value
Next

Keywords.ReadOnly = True

Set Contextuals = New KeyedList
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
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 Default Function Item(ByVal Token)
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

Class NameConstruct
Public OldPathName
Public NewPathName

Private Sub Class_Initialize()
Set OldPathName = Nothing
Set NewPathName = Nothing
End Sub

Public Property Get Kind()
Kind = snName
End Property
End Class

Class OnComputedConstruct
Public Targets
Public Value
Public IsGoTo

Private Sub Class_Initialize()
Set Targets = New KeyedList
Set Value = Nothing
End Sub

Public Property Get Kind()
Kind = snOnComputed
End Property
End Class

Class OnErrorConstruct
Public Statement

Private Sub Class_Initialize()
Set Statement = Nothing
End Sub

Public Property Get Kind()
Kind = snOnError
End Property
End Class

Class OpenConstruct
Public PathName
Public FileMode
Public FileAccess
Public FileLock
Public FileNumber
Public Length

Private Sub Class_Initialize()
Set PathName = Nothing
Set FileNumber = Nothing
Set Length = Nothing
End Sub

Public Property Get Kind()
Kind = snOpen
End Property
End Class

Class Operator
Public Value

Private Sub Class_Initialize()
Set Value = Nothing
End Sub

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

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

Class Parameter
Public Index
Public IsOptional
Public IsByVal
Public IsParamArray
Public IsArray
Public DataType
Public Id
Public Init

Private Sub Class_Initialize()
Set DataType = Nothing
Set Id = Nothing
Set Init = Nothing
End Sub
End Class

Class AccessToken
Public Access
Public Token

Private Sub Class_Initialize()
Set Token = Nothing
End Sub
End Class

Const Msg_ = "Invalid literal"
Const LF_ = 10 'Line feed
Const CR_ = 13 'Carriage return
Const SP_ = 32 'Space
Const US_ = 95 'Underscore
Const BS_ = 8 'Backspace. Used for line continuation
Const CRLF_ = &HA000D
Class Tokenizer
Private File_
Private RunningLine_
Private RunningColumn_
Private FrozenColumn_
Private PreviousColumn_
Private FilePath_
Private UnChars_
Private ReadBinChars_
Private ReadOctalChars_
Private ReadHexaChars_
Private MonthNames_

Private Sub Class_Initialize()
RunningLine_ = 0
RunningColumn_ = 1

Set ReadBinChars_ = New KeyedList
ReadBinChars_.AddKVPairs Array("0", "0", "1", "1")

Set ReadOctalChars_ = New KeyedList
ReadOctalChars_.AddKVPairs Array("0", "0", "1", "1", "2", "2", "3", "3", "4", "4", "5", "5", "6", "6", "7", "7")

Set ReadHexaChars_ = New KeyedList
ReadHexaChars_.AddKVPairs Array("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")

MonthNames_ = Array("January", "February", "March", "April", "May", "June", _
"July", "August", "September", "October", "November", "December")

Set File_ = Nothing
End Sub

Private Property Let Middle(ByRef Text, ByVal Start, ByVal Length, ByVal Value)
Text = Left(Text, Start - 1) & Value & Mid(Text, Start + Length)
End Property

Private Function AtEnd()
AtEnd = File_.AtEndOfStream
End Function

Public Sub OpenFile(ByVal FilePath)
FilePath_ = FilePath

With CreateObject("Scripting.FileSystemObject")
If Not .FileExists(FilePath) Then Err.Raise 53
Set File_ = .OpenTextFile(FilePath, ForReading, Named("Create:=", False), Named("Format:=Unicode", True))
End With

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

Public Function GetToken()
Dim Token

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

Do
Dim Done: Done = True
FrozenColumn_ = RunningColumn_
Dim Cp: Cp = GetCodePoint
Dim Ch: Ch = ChrW(Cp)

Select Case Ch
Case "["
Set Token = ReadEscapedIdentifier

Case """"
Set Token = ReadString

Case "&"
Set Token = ReadAmpersand

Case "#"
Set Token = ReadHash

Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"
Set Token = ReadNumber(Ch)

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

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

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

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

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

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

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

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

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

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

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(opGt, , , tkOperator)

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(Named("IsRem:=", False))

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(Named("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()
Dim CheckLF, Cp2, Cp3

Dim Cp1: 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()
Dim Result

If UnChars_ = "" Then
If AtEnd Then Fail "Unexpected end of file"
Result = File_.Read(1)
Else
Result = Left(UnChars_, 1)
UnChars_ = Mid(UnChars_, 2)
End If

RunningColumn_ = RunningColumn_ + 1
NextCodePoint = AscW(Result)
End Function

Private Function GetChar()
Dim Cp: Cp = GetCodePoint
GetChar = ChrW(Cp)
End Function

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

Private Sub UngetChar(ByVal Character)
Dim Length: Length = SizeOf(kwInteger)
If Character = vbBack Then Length = Length * 2 + Len(vbNewLine) * SizeOf(kwInteger)
UnChars_ = Character & UnChars_

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

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

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

Private Function ReadIdentifier(ByVal CodePoint)
Const MAX_LENGTH = 255
Dim Ch

Dim Suffix: Suffix = vbNullChar
Dim Buffer: Buffer = Access(MAX_LENGTH, vbNullChar)

Dim Count: Count = 1
Middle(Buffer, Count, 1) = ChrW(CodePoint)

Do Until AtEnd
Dim Cp: Cp = GetCodePoint
Ch = ChrW(Cp)

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

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

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

Case Else
UngetChar Ch
End Select

Dim Result: Set Result = NewToken(, , Suffix, tkIdentifier)
Dim Name: Name = Left(Buffer, Count)
Dim Index: Index = NameBank_.Keywords.IndexOf(Name)

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

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

If Index <> 0 Then
Index = Index + NameBank_.Keywords.Count
Else
Index = NameBank_.Ids.IndexOf(Name)

If Index = 0 Then
NameBank_.Ids.Add Name, Name
Index = NameBank_.Ids.Count
End If

Index = Index + NameBank_.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 And Result.Suffix = "$" Then
Result.Kind = tkIdentifier
If Not NameBank_.Ids.Exists("String") Then NameBank_.Ids.Add "String", "String"
Index = NameBank_.Ids.IndexOf("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()
Const MAX_LENGTH = 255

Dim Count

Dim Suffix: Suffix = vbNullChar
Dim Buffer: Buffer = Access(MAX_LENGTH, vbNullChar)

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

Count = Count + 1
If Count > MAX_LENGTH Then Fail "Identifier too long"
Middle(Buffer, Count, 1) = ChrW(Cp)
Loop

If Not AtEnd Then
Suffix = GetChar

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

Case Else
UngetChar Suffix
Suffix = vbNullChar
End Select
End If

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

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

Set ReadEscapedIdentifier = Token
End Function

Private Function ReadString()
Const MAX_LENGTH = 1013

Dim Count, Ch

Dim Buffer: Buffer = Access(MAX_LENGTH, vbNullChar)

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(, Named("Text:=", Left(Buffer, Count)), , tkString)
End Function

Private Function Append(ByVal Count, ByRef Buffer, ByVal Ch)
Count = Count + 1
Middle(Buffer, Count, 1) = Ch
Append = Count
End Function

Private Function ReadInteger(ByVal FirstDigit)
Const MAX_LENGTH = 29

Dim Count

Dim Suffix: Suffix = vbNullChar
Dim Buffer: Buffer = Access(MAX_LENGTH, vbNullChar)

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

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

Select Case Ch
Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"
Count = Count + 1
Middle(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(, Named("Text:=", Left(Buffer, Count)), Suffix, tkIntegerNumber)
End Function

Private Function ReadFloat(ByVal FirstDigit)
Dim Result: Set Result = ReadInteger(FirstDigit)

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

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

Set ReadFloat = Result
End Function

Private Function ReadNumber(ByVal FirstDigit)
Dim Result: Set Result = ReadFloat(FirstDigit)

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

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

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

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

Case Else
UngetChar Ch
End Select
End If
End If

Set ReadNumber = Result
End Function

Private Function ReadAmpersand()
Dim Token

Dim Ch: Ch = GetChar

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

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

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

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

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

Set ReadAmpersand = Token
End Function

Private Function ReadBin()
Set ReadBin = ReadBOH(ReadBinChars_, 96, tkBinaryNumber)
End Function

Private Function ReadOctal()
Set ReadOctal = ReadBOH(ReadOctalChars_, 32, tkOctalNumber)
End Function

Private Function ReadHexa()
Set ReadHexa = ReadBOH(ReadHexaChars_, 24, tkHexaNumber)
End Function

Private Function ReadHash()
Dim Name

Rem Let's get the first number.
Dim Token: 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(, Named("Text:=", Name), , tkDirective)
Exit Function

Case ""
Fail Msg_

Case Else
Dim Number: 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(, Named("Text:=", Name), , tkFileHandle)
Exit Function
End If

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

Rem Let's get the first separator.
Dim Cp: Cp = GetCodePoint
Dim Ch: Ch = ChrW(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(, Named("Text:=", Name), , tkDateTime)
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(, Named("Text:=", ReadTime("")), , tkDateTime)
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(, Named("Text:=", Name & " 00:00:00"), , tkDateTime)

Case Else
Fail Msg_
End Select
End Function

Private Function ReadDate(ByVal FirstNumber, ByVal Separator)
Dim YYYY, MM, DD, Result

Dim SecondNumber: Set SecondNumber = ReadInteger("")
If SecondNumber.Text = "" Then Fail Msg_

Rem The next separator must match the first one.
Dim Ch: Ch = GetChar
If Ch <> Separator Then Fail Msg_

Dim ThirdNumber: Set ThirdNumber = ReadInteger("")
If ThirdNumber.Text = "" Then Fail Msg_

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

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

Rem Validate year.
If YYYY > 9999 Then Fail Msg_

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

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

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

Case Else
If DD > 31 Then Fail Msg_
End Select

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

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

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

ReadDate = Result
End Function

Private Function ReadTime(ByVal FirstNumber)
Dim SS, Ch2, AP

Dim HH: HH = CInt(FirstNumber)
Dim Number: Number = ReadInteger("")
If Number = "" Then Err.Raise 0
Dim NN: NN = CInt(Number)

Dim Ch: Ch = GetChar

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

If Not AtEnd Then
Ch = GetChar

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

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

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

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

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

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

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

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

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

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

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

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

ReadTime = Number
End Function

Private Function ReadMonthName()
Dim Result, Prv
Dim Ch: Ch = vbNullChar

Do Until AtEnd
Prv = Ch
Ch = GetChar

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

Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"
Rem We safely can assume we read two characters more than needed.
UngetChar Ch
UngetChar Prv
Result = Left(Result, Len(Result) - 1)
Exit Do

Case Else
Result = Result & Ch
End Select
Loop

ReadMonthName = Result
End Function

Private Function ConvertNameToNumber(ByVal Name)
Dim Count, Result, MonthName

For Each MonthName In MonthNames_
Count = Count + 1

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

ConvertNameToNumber = Result
End Function

Private Function NewToken( _
ByVal Code, _
ByVal Text, _
ByVal Suffix, _
ByVal Kind _
)
If IsMissing(Code) Then Code = 0
If IsMissing(Text) Then Text = ""
If IsMissing(Suffix) Then Suffix = vbNullChar

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(ByVal IsRem)
Const MAX_LENGTH = 1013

Dim Text

Dim Buffer: Buffer = Access(MAX_LENGTH, vbNullChar)

If IsRem Then
Text = v.Rem & " "
Else
Text = " '"
End If

Dim Count: Count = Len(Text)
Middle(Buffer, 1, Count) = Text

Do Until AtEnd
If Count = MAX_LENGTH Then Fail "Comment too long"
Dim Ch: Ch = GetChar
If Ch = vbLf Then Exit Do

Count = Count + 1
Middle(Buffer, Count, 1) = Ch
Loop

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

Private Sub DiscardComment()
Dim Count: Count = 1

Do Until AtEnd
Dim Ch: Ch = GetChar

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

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

Private Sub Class_Terminate()
If Not File_ Is Nothing Then File_.Access
End Sub

Private Function ReadBOH(ByVal AllowedChars, ByVal MaxLength, ByVal Kind)
Dim Count

Dim Suffix: Suffix = vbNullChar
Dim Buffer: Buffer = Access(96, vbNullChar)

Do Until AtEnd
If Count = MaxLength Then Fail "Literal too long"
Dim Ch: Ch = GetChar

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

Case "_"
Rem We'll ignore it

Case Else
If Not AllowedChars.Exists(Ch) Then
UngetChar Ch
Exit Do
End If

Count = Count + 1
Middle(Buffer, Count, 1) = Ch
End Select
Loop

If Count = 0 Then Fail "Invalid literal"
Set ReadBOH = NewToken( , Named("Text:=", Left(Buffer, Count)), Suffix, Kind)
End Function
End Class

Class Parser
Private Downgrade_
Private WasAs_
Private LastToken_
Private LookAhead_
Private Scanner_
Private Source_
Private State_

Private Sub Class_Initialize()
Set Scanner_ = New Tokenizer
Set LastToken_ = Nothing
Set LookAhead_ = Nothing
Set Source_ = Nothing
End Sub

Public Property Set SourceFile(ByVal Source)
Set Scanner_ = New Tokenizer
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()
Set SourceFile = Source_
End Property

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

Public Function NextTokenForPrint()
Set NextTokenForPrint = InternalNextToken(True)
End Function

Public Function NextToken()
Set NextToken = InternalNextToken(False)
End Function

' 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.
Private Function InternalNextToken(ByVal ForPrint)
Dim Done, Revoke, Upgrade, Spaces, Name

Dim Token: Set Token = Nothing
Dim LastToken: Set LastToken = Nothing

Do
Done = True

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

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

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

Case tkKeyword
If Downgrade_ Then
Downgrade_ = False
Name = NameBank_(Token)

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

Token.Kind = tkIdentifier

Else
Select Case Token.Code
Case kwAs
WasAs_ = True

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

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

Case kwDeclare
If State_ = ncNone Then State_ = ncDeclare

Case kwFor
If State_ = ncNone Then
State_ = ncForNext

ElseIf State_ = ncOpen01 Then
State_ = ncOpen02
End If

Case kwInput
If State_ = ncOpen02 Then State_ = ncOpen03

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

Case kwOpen
If State_ = ncNone Then State_ = ncOpen01

Case kwOption
If State_ = ncNone Then State_ = ncOption

Case kwOn
If State_ = ncNone Then State_ = ncOn

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

Case kwTo
If State_ = ncForNext Then State_ = ncForTo

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

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

Case tkIdentifier
Downgrade_ = False
WasAs_ = False

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

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

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

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

Case Else
Upgrade = True
End Select

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

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

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

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

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

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

Case ncDeclare
Upgrade = Token.Code = cxPtrSafe

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

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

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

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

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

Case ncOpen02
Upgrade = Token.Code = cxAppend
If Not Upgrade Then Upgrade = Token.Code = cxBinary
If Not Upgrade Then Upgrade = Token.Code = cxOutput
If Not Upgrade Then Upgrade = Token.Code = cxRandom
State_ = ncOpen03

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

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

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

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

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

Case tkFileHandle
If State_ = ncOpen10 Then State_ = ncOpen11

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

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

Case tkWhiteSpace
Done = False
Spaces = Spaces + 1

Case tkSoftLineBreak, tkHardLineBreak
WasAs_ = False
End Select

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

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 And Token.Spaces = 0 Then Token.Spaces = Spaces
Set InternalNextToken = Token
End Function

Rem Parses Source's content.
Rem Results are in Source's properties like Consts, Enums, etc.
Public Sub Parse(ByVal Source)
Dim Name, Token, Mark, Entity

Dim AccessToken: Set AccessToken = New 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 Msg001, Token, Msg007

Else
Fail Msg002, Token, Msg007
End If

Set Mark = Token

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

Set Entity.Id = NewId(Token)
MustEatLineBreak

Set 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 v.End, Token, Msg004
End If

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

Name = NameBank_(Entity.Id.Name)
If Source_.Entities.Exists(Name) Then Fail , Entity.Id.Name, Msg006 & Name
Source_.Entities.Add Name, Entity
MustEatLineBreak
Loop
End Sub

Private Function ParseDeclarationArea(ByVal Entity)
Dim HadBase, HadCompare, Text, Access, Token

Do
Set Token = SkipLineBreaks

If Token.Kind = tkKeyword Then
Select Case Token.Code
Case kwOption
If Access <> acLocal Then Fail Msg003, Token, Msg008
Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail v.Option, Token, Msg015

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

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

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

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

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

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

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

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

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

Case cxText
Entity.OptionCompare = vbTextCompare

Case Else
Fail Msg014, Token, Msg013
End Select

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

Case Else
Fail v.Option, Token, Msg015
End Select

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Case kwEnum
ParseEnum Access, Entity
Access = acLocal

Case kwDeclare
ParseDeclare Access, Entity
Access = acLocal

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

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

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

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

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

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

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

Case Else
Fail , Token, Msg018
End Select

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

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

Else
Fail , Token, Msg018
End If
Loop

Dim Result: Set Result = New AccessToken

With Result
.Access = Access
Set .Token = Token
End With

Set ParseDeclarationArea = Result
End Function

Private Function ParseProcedureArea(ByVal Entity, ByRef AccessToken)
Dim IsDefault, HadDefault, IsIterator, HadIterator, IsStatic

Dim Proc: Set Proc = Nothing
Dim Func: Set Func = Nothing
Dim Prop: Set Prop = Nothing

Dim Access: Access = AccessToken.Access
Dim Token: Set Token = AccessToken.Token

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

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

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

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

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

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

Case kwSub
Set Proc = ParseSub(Access, Entity)
Proc.IsDefault = IsDefault
Proc.IsStatic = IsStatic
IsStatic = False
IsDefault = False
IsIterator = False
Access = acLocal

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

Case cxProperty
Set Prop = ParseProperty(Access, Entity)
Prop.IsDefault = IsDefault
Prop.IsStatic = IsStatic
IsStatic = False
IsDefault = False
IsIterator = False
Access = acLocal

Case Else
Exit Do
End Select

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

Set ParseProcedureArea = Token
End Function

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

Do
Set Token = SkipLineBreaks
Set Mark = Token

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

First = NameBank_(Token)
Set Token = NextToken

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

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, Msg022
End If

On Error GoTo 0

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

Private Function ParseConsts( _
ByVal InsideProc, _
ByVal Access, _
ByVal Entity, _
ByVal Body _
)
Dim Name

If IsMissing(InsideProc) Then InsideProc = False
Dim Token: Set Token = Nothing
Dim Cnt: Set Cnt = Nothing
Dim Xp: Set Xp = New Expressionist

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

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

Set Token = NextToken

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

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

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

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

Set Cnt.DataType.FixedLength = Xp.GetExpression(, Me)
Set Token = Xp.LastToken
If Cnt.DataType.FixedLength Is Nothing Then Fail , Token, Msg065
End If

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

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

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

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

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

Rem Save it
Body.Add 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 Msg027, Token, Msg023
Loop

Set ParseConsts = Token
End Function

Private Sub ParseEnum(ByVal Access, ByVal Entity)
Dim Emd

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

Dim Enm: 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 Msg031, Token, Msg028

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

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

Set Token = NextToken

If Token.IsOperator(opEq) Then
Set Emd.Value = Xp.GetExpression(, Me)
Set Token = Xp.LastToken
If Emd.Value Is Nothing Then Fail , Token, Msg065
End If

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

Enm.Enumerands.Add NameBank_(Emd.Id.Name), Emd
Loop While IsBreak(Token)

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

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

If Enm.Enumerands.Count = 0 Then Fail , Enm, Msg035
CheckDupl , Entity, Enm.Id.Name

Entity.Enums.Add NameBank_(Enm.Id.Name), Enm
End Sub

Private Sub ParseDeclare(ByVal Access, ByVal Entity)
Dim Dcl: Set Dcl = New DeclareConstruct
If Access = acLocal Then Access = acPublic
Dcl.Access = Access

Rem Is it PtrSafe?
Dim Token: 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 Msg037, Token, Msg036
End If

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

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 v.Lib, Token, Msg036

Rem Get Lib's name
Set Token = NextToken
If Token.Kind <> tkString Then Fail Msg038, Token, Msg036
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 Msg039, Token, Msg036

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

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

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

Rem Get data type name
Set Token = NextToken

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

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

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

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

Case Else
Fail Msg025, Token, Msg036
End Select

Rem Maybe it returns an array?
If Token.Kind = tkLeftParenthesis Then
Set Token = NextToken
If Token.Kind <> tkRightParenthesis Then Fail Msg057, Token, Msg036
Dcl.DataType.IsArray = True

Set Token = NextToken
End If
End If

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

Set Dcl.DataType = NewDataType(Tkn)

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

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

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

Entity.Declares.Add NameBank_(Dcl.Id.Name), Dcl
End Sub

Private Function ParseParms(ByVal Entity, ByVal SignatureKind, ByVal Parms)
Dim Count, Index, Name, CurrParm

Dim Xp: Set Xp = New Expressionist
Dim LastParm: Set LastParm = New Parameter
Dim Token: Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = NextToken

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

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

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

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

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

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

Set Token = NextToken

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

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

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

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

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

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

Set CurrParm.DataType.Id.Name = Token

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

Set Token = NextToken
End If

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

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

If Token.IsOperator(opEq) Then
If Not CurrParm.IsOptional Then Fail , Token, Msg053
If CurrParm.IsParamArray Then Fail , Token, Msg054
Set CurrParm.Init = Xp.GetExpression(, Me)
Set Token = Xp.LastToken
If CurrParm.Init Is Nothing Then Fail , Token, Msg065
End If

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

GoSub AddParm
Set Token = NextToken
Exit Do
End If

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

If SignatureKind = skPropertyLet Or SignatureKind = skPropertySet Then
If Parms.Count = 0 Then
Fail , Token, Msg078

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

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

Private Sub AddParm(ByVal CurrParm, ByVal Parms, ByVal SignatureKind)
Dim Count

Dim Name: Name = NameBank_(CurrParm.Id.Name)

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

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

Parms.Add Name, CurrParm
End Sub

Private Sub ParseEvent(ByVal Entity)
Dim Token: Set Token = SkipLineBreaks
If Not IsProperId(, Token) Then Fail Msg003, Token, Msg012

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

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

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

Private Sub ParseImplements(ByVal Entity)
Dim Token: Set Token = SkipLineBreaks
If Token.Kind <> tkIdentifier Then Fail Msg059, Token, Msg058
If Token.Suffix <> vbNullChar Then Fail , Token, Msg060

Dim Impls: 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 Msg003, Token, Msg058
If Token.Suffix <> vbNullChar Then Fail , Token, Msg060

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

If Not IsBreak(Token) Then Fail Msg031, Token, Msg058
Set Token = Impls.Id.Name
Dim Name: Name = NameBank_(Token)
If Entity.Impls.Exists(Name) Then Fail , Token, Msg006 & Name
Entity.Impls.Add Name, Impls
End Sub

Private Function ParseSub(ByVal Access, ByVal Entity)
If Access = acLocal Then Access = acPublic
Dim Proc: Set Proc = New SubConstruct
Proc.Access = Access

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

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

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

ElseIf Not IsBreak(Token) Then
Fail Msg031, Token, Msg069
End If
Set Token = ParseBody(, , Entity, Proc.Body)
If Not Token.IsKeyword(kwSub) Then Fail v.Sub, Token, Msg072
MustEatLineBreak

Dim Name: Name = NameBank_(Proc.Id.Name)
CheckDupl , Entity, Proc.Id.Name
Entity.Subs.Add Name, Proc

Set ParseSub = Proc
End Function

Private Function ParseFunction(ByVal Access, ByVal Entity)
Dim Parm

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

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

Dim Func: Set Func.Id = NewId(Token)
Dim Name: Name = NameBank_(Func.Id.Name)

Set Token = NextToken

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

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

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

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

Set Token = NextToken

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

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

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

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

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

If Not IsBreak(Token) Then MustEatLineBreak
Set Token = ParseBody(, , Entity, Func.Body)
If Not Token.IsKeyword(kwFunction) Then Fail v.Function, Token, Msg073
MustEatLineBreak

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

Set ParseFunction = Func
End Function

Private Function ParseProperty(ByVal Access, ByVal Entity)
Dim IsNew, Idx, Kind, Parm, Slot, LeftParms, RightParms

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

Dim Token: Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail , Token, Msg086

Select Case Token.Code
Case kwGet
Kind = VbGet

Case kwLet
Kind = VbLet

Case kwSet
Kind = VbSet

Case Else
Fail Msg076, Token, Msg071
End Select

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

Dim PropToken: Set PropToken = Token
Dim Name: Name = NameBank_(Token)

CheckDupl Named("JumpProp:=", True), Entity, Token

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

Set Token = NextToken

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

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

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

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

Set Token = NextToken

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

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

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

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

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

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

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

Set Token = ParseBody(, , Entity, Prop.Body)
If Token.Kind <> tkIdentifier Or Token.Code <> cxProperty Then Fail , Token, Msg074
MustEatLineBreak

If IsNew Then
Entity.Properties.Add Name, Slot

ElseIf Slot.Exists(Kind) Then
Fail , PropToken, Msg006 & 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, Msg077
If Parm.IsParamArray Then Fail , Slot.Id.Name, Msg077
End If

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

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

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

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

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

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

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

Set ParseProperty = Prop
End Function

Private Sub ParseDim( _
ByVal InsideProc, _
ByVal IsStatic, _
ByVal Token, _
ByVal Access, _
ByVal Entity, _
ByVal Vars _
)
Dim Name, WasArray, Var, Expr, Subs, Bin

If IsMissing(InsideProc) Then InsideProc = False
If IsMissing(IsStatic) Then IsStatic = False
If IsMissing(Token) Then Set Token = Nothing

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

Dim Xp: 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 Entity.IsClass Then Fail , Token, Msg016
If InsideProc Then Fail , Token, Msg063

Var.HasWithEvents = True
Set Token = NextToken
End If

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

Set Token = NextToken
WasArray = False

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

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

Case ekBinaryExpr
Set Bin = Expr
Set Subs = New SubscriptPair

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

Case Else
Fail , Token, Msg065
End Select

Var.Subscripts.Add , Subs
End If

If Token.Kind <> tkListSeparator Then Exit Do
Loop

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

WasArray = True
Set Token = NextToken
End If

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

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

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

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

Set Token = NextToken

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

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

Set Token = NextToken
End If

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

Else
Set Var.DataType = Entity.DefTypes(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, Msg065
End If

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

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

Name = NameBank_(Var.Id.Name)
If Not InsideProc Then CheckDupl , Entity, Var.Id.Name
If Vars.Exists(Name) Then Fail , Token, Msg006 & Name
Vars.Add Name, Var

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

Private Sub ParseType(ByVal Access, ByVal Entity)
Dim Name, Var

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

Dim Token: Set Token = NextToken
If Not IsProperId(, Token) Then Fail Msg003, Token, Msg028

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

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

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

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

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

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

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

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

Private Function ParseBody( _
ByVal IsSingleLine, _
ByVal LookAhead, _
ByVal Entity, _
ByVal Body _
)
Dim Token, Stmt, LStmt, SStmt, Label, LinNum

If IsMissing(IsSingleLine) Then IsSingleLine = False
If IsMissing(LookAhead) Then Set LookAhead = Nothing

Dim Xp: 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 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, Msg094
If Stmt.Kind <> snCall Then Stopp 3
Body.Add , Stmt

Case kwClose
Set LookAhead = ParseClose(Entity, Body)

Case kwConst
Set LookAhead = ParseConsts(Named("InsideProc:=", True), acLocal, Entity, Body)

Case kwContinue
ParseContinue Entity, Body

Case kwDebug
Rem HACK:
Set Stmt = Xp.GetStmt(Token, LookAhead, Me)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail , Token, Msg094
Body.Add , Stmt

Case kwDim
ParseDim Named("InsideProc:=", True), , , acLocal, Entity, Body

Case kwDo
ParseDo Entity, 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(Entity, Body)

Case kwExit
ParseExit Entity, Body

Case kwFor
Set LookAhead = ParseFor(Entity, Body)

Case kwGet
ParseGet Entity, Body

Case kwGoSub
ParseGoSub Entity, Body

Case kwGoTo
ParseGoTo Entity, Body

Case kwIf
Set LookAhead = ParseIf(Entity, Body)

Case kwInput
Set LookAhead = ParseInput(Entity, Body)

Case kwLet
Set Stmt = Xp.GetStmt(, , Me)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail , Token, Msg094
If Stmt.Kind <> snLet Then Stopp 4
Body.Add , Stmt

Case kwLSet
Set LookAhead = ParseLSet(Entity, Body)

Case kwOn
Set LookAhead = ParseOn(Entity, Body)

Case kwOpen
Set LookAhead = ParseOpen(Entity, Body)

Case kwPrint
Set LookAhead = ParsePrint(Entity, Body)

Case kwPut
ParsePut Entity, Body

Case kwRaiseEvent
Set LookAhead = ParseRaiseEvent(Entity, Body)

Case kwReDim
ParseReDim Entity, Body

Case kwResume
Set LookAhead = ParseResume(Entity, Body)

Case kwReturn
Body.Add , New ReturnConstruct

Case kwRSet
Set LookAhead = ParseRSet(Entity, Body)

Case kwSeek
Set LookAhead = ParseSeek(Entity, Body)

Case kwSelect
ParseSelect Entity, Body

Case kwSet
Set Stmt = Xp.GetStmt(, , Me)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail , Token, Msg094
If Stmt.Kind <> snLet Then Stopp 5

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 Named("InsideProc:=", True), Named("IsStatic:=", True), , acLocal, Entity, Body

Case kwStop
Body.Add , New StopConstruct

Case kwUnlock
Set LookAhead = ParseUnlock(Entity, Body)

Case kwWhile
ParseWhile Entity, Body

Case cxWidth
Set LookAhead = ParseWidth(Entity, Body)

Case kwWith
ParseWith Entity, Body

Case kwWrite
Set LookAhead = ParseWrite(Entity, Body)

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

Case cxName
Set LookAhead = ParseName(Entity, Body)

Case Else
MsgBox "Should not happen (2)"
Err.Raise 5
End Select

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

Case cxReset
Body.Add , New ResetConstruct

Case cxWidth
Set LookAhead = ParseWidth(Entity, Body)

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

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

Case tkOperator
Select Case Token.Code
Case opWithBang, opWithDot
Set Stmt = Xp.GetStmt(Token, LookAhead, Me)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail , Token, Msg094
Body.Add , Stmt

Case Else
MsgBox "Should not happen (3)"
Err.Raise 5
End Select

Case tkHardLineBreak
Rem Nothing to do

Case Else
Fail , Token, Msg087
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)
Select Case Token.Kind
Case tkOperator
IsStatement = Token.Code = opWithBang Or Token.Code = opWithDot

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

Private Function ParseClose(ByVal Entity, ByVal Body)
Dim Token, Expr

Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

Dim Stmt: 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 Entity, ByVal Body)
Dim Stmt: Set Stmt = New ContinueConstruct
Dim Token: Set Token = NextToken

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

Select Case Token.Code
Case kwDo
Stmt.What = cwDo

Case kwFor
Stmt.What = cwFor

Case kwWhile
Stmt.What = cwWhile
End Select

Body.Add , Stmt
End Sub

Private Sub ParseDo(ByVal Entity, ByVal Body)
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

Dim Stmt: Set Stmt = New DoConstruct
Dim Token: Set Token = NextToken
Dim Mark: 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, Msg065

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, Msg065
End If

If Not IsBreak(Token) Then Fail , Token, Msg031
Set Token = ParseBody(, , Entity, Stmt.Body)

If Not Token.IsKeyword(kwLoop) Then Fail , Token, Msg096

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

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, Msg065
End If
End If

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

Private Function ParseErase(ByVal Entity, ByVal Body)
Dim Token, Sym

Dim Stmt: Set Stmt = New EraseConstruct

Do
Set Token = NextToken
If Token.Kind <> tkIdentifier Then Fail Msg003, Token, Msg097

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 Entity, ByVal Body)
Dim Stmt: Set Stmt = New ExitConstruct
Dim Token: Set Token = NextToken

If Token.IsKeyword(kwDo) Then
Stmt.What = ewDo

ElseIf Token.IsKeyword(kwFor) Then
Stmt.What = ewFor

ElseIf Token.IsKeyword(kwWhile) Then
Stmt.What = ewWhile

ElseIf Token.IsKeyword(kwSub) Then
Stmt.What = ewSub

ElseIf Token.IsKeyword(kwFunction) Then
Stmt.What = ewFunction

ElseIf Token.Kind = tkIdentifier And Token.Code = cxProperty Then
Stmt.What = ewProperty

ElseIf Token.IsKeyword(kwSelect) Then
Stmt.What = ewSelect

Else
Fail , Token, Msg098
End If

Body.Add , Stmt
End Sub

Private Function ParseFor(ByVal Entity, ByVal Body)
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Xp.CanHaveTo = True
Dim Token: Set Token = NextToken

If Token.IsKeyword(kwEach) Then
ParseForEach Entity, Body
Set ParseFor = Nothing
Exit Function
End If

Dim Stmt: Set Stmt = New ForConstruct
If Not IsProperId(, Token) Then Fail Msg003, Token, Msg099

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

Set Token = NextToken
If Not Token.IsOperator(opEq) Then Fail "=", Token, Msg099
Dim Mark: Set Mark = Token

Dim Expr: Set Expr = Xp.GetExpression(, Me)
Set Token = Xp.LastToken

If Expr Is Nothing Then Fail , Mark, Msg065
If Expr.Kind <> ekBinaryExpr Then Fail , Mark, Msg065
Dim Bin: Set Bin = Expr
If Not Bin.Operator.Value.Code = opTo Then Fail v.To, Token, Msg099

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

If Token.Kind = tkIdentifier And Token.Code = 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 Msg100, Mark, Msg099
Else
Dim Lit: Set Lit = New Literal
Set Lit.Value = New Token
Lit.Value.Kind = tkIntegerNumber
Lit.Value.Text = "1"
Set Stmt.Increment = Lit
End If

If Not IsBreak(Token) Then Fail , Token, Msg031
Set Token = ParseBody(, , Entity, Stmt.Body)

If Token.IsKeyword(kwNext) Then
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, Msg031
End If

ElseIf IsBreak(Token) Then
Rem OK

Else
Fail , Token, Msg031
End If

Else
Fail , Token, Msg101
End If

Body.Add , Stmt
Set ParseFor = Token
End Function

Private Sub ParseForEach(ByVal Entity, ByVal Body)
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

Dim Stmt: Set Stmt = New ForEachConstruct
Dim Token: Set Token = NextToken
If Not IsProperId(, Token) Then Fail Msg103, Token, Msg102

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

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

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

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

Set Token = ParseBody(, , Entity, Stmt.Body)
If Not Token.IsKeyword(kwNext) Then Fail , Token, Msg101

MustEatLineBreak
Body.Add , Stmt
End Sub

Private Sub ParseGet(ByVal Entity, ByVal Body)
Dim Stmt: Set Stmt = New GetConstruct
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

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

If Stmt.FileNumber Is Nothing Then Fail Msg110, Token, Msg105
If Token.Kind <> tkListSeparator Then Fail ",", Token, Msg105

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

Set Token = NextToken
If Not IsProperId(Named("CanHaveSuffix:=", True), Token) Then Fail Msg103, Token, Msg105

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

Private Sub ParseGoSub(ByVal Entity, ByVal Body)
Dim Stmt: Set Stmt = New GoSubConstruct
Dim Token: Set Token = NextToken

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

Set Stmt.Target = Label

ElseIf Token.Kind = tkLineContinuation Then
Dim LinNum: Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token

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

Body.Add , Stmt
End Sub

Private Sub ParseGoTo(ByVal Entity, ByVal Body)
Dim Stmt: Set Stmt = New GoToConstruct
Dim Token: Set Token = NextToken

Select Case Token.Kind
Case tkIdentifier
Dim Label: Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Set Stmt.Target = Label

Case tkIntegerNumber
Dim LinNum: Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token

Set Stmt.Target = LinNum

Case Else
Fail , Token, Msg108
End Select

Body.Add , Stmt
End Sub

Private Function ParseIf(ByVal Entity, ByVal Body)
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

Dim Stmt: Set Stmt = New IfConstruct

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

Rem If <condition> Then ?
Set Token = Xp.LastToken
If Not Token.IsKeyword(kwThen) Then Fail v.Then, Token, Msg088

Stmt.Arms.Add , Arm
Set Token = NextToken

If Token.Kind = tkSoftLineBreak Then
Set Token = Nothing
SubGoTo2 Token, Entity, Arm, Stmt

ElseIf IsHardBreak(Token) Then
Set Token = ParseBody(, , Entity, Arm.Body)
If Token.Kind <> tkKeyword Then Fail , Token, Msg089

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

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

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

Case kwElse
Set Token = NextToken
If Not IsHardBreak(Token) Then Fail , Token, Msg027

Set Token = ParseBody(, , Entity, Stmt.ElseBody)

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

Fail , Token, Msg085 & v.If

Case kwIf
Set Token = NextToken
Exit Do

Case Else
Fail , Token, Msg089
End Select
Loop

ElseIf IsStatement(Token) Then
SubGoTo2 Token, Entity, Arm, Stmt

Else
Fail , Token, Msg090
End If

Body.Add , Stmt
Set ParseIf = Token
End Function

Private Sub SubGoTo2(ByRef Token, ByVal Entity, ByVal Arm, ByVal Stmt)
Do
If Token Is Nothing Then
Set Token = NextToken
If IsHardBreak(Token) Then Exit Do
End If

If Not IsStatement(Token) Then Fail , Token, Msg087

Rem If <condition> Then : <statement>
Set Token = ParseBody(Named("IsSingleLine:=", True), Named("LookAhead:=", Token), Entity, Arm.Body)
If Token.Kind <> tkSoftLineBreak Then Exit Do
Set Token = Nothing
Loop

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

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

If Not IsHardBreak(Token) Then Fail , Token, Msg031
End Sub

Private Function ParseInput(ByVal Entity, ByVal Body)
Dim Sym

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

Set Stmt.FileNumber = Xp.GetExpression(, Me)
Dim Token: Set Token = Xp.LastToken
If Token.Kind <> tkListSeparator Then Fail ",", Token, Msg109

Do
Set Token = NextToken
If Not IsProperId(Named("CanHaveSuffix:=", True), Token) Then Fail Msg103, Token, Msg109

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 Entity, ByVal Body)
Dim Stmt: Set Stmt = New LockConstruct
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(, Me)
If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg112

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

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

Private Function ParseLSet(ByVal Entity, ByVal Body)
Dim Xp: Set Xp = New Expressionist
Dim Stmt: Set Stmt = New LSetConstruct

Dim ISt: Set ISt = Xp.GetStmt(, , Me)
If ISt.Kind <> snLet Then Stopp 6

Dim Asg: Set Asg = ISt
If Asg.Name.Kind <> ekSymbol Then Stopp 7
If Asg.Operator.Value.Code <> opEq Then Fail , Asg.Operator.Value, Msg114

Set Stmt.Name = Asg.Name
Set Stmt.Value = Asg.Value
Body.Add , Stmt
End Function

Private Function ParseName(ByVal Entity, ByVal Body)
Dim Stmt: Set Stmt = New NameConstruct
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.OldPathName = Xp.GetExpression(, Me)
If Stmt.OldPathName Is Nothing Then Fail Msg116, Xp.LastToken, Msg115
If Xp.LastToken.IsKeyword(kwAs) Then Fail v.As, Xp.LastToken, Msg115

Set Stmt.NewPathName = Xp.GetExpression(, Me)
If Stmt.NewPathName Is Nothing Then Fail Msg117, Xp.LastToken, Msg115

Body.Add , Stmt
Set ParseName = Xp.LastToken
End Function

Private Function ParseOn(ByVal Entity, ByVal Body)
Dim WentTo, Label, OnStmt, Comp, LinNum

Dim Xp: Set Xp = New Expressionist
Dim Token: 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
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, Msg105
End Select

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

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

Else
Fail Token, Msg110
End If

Set Token = NextToken
Body.Add , OnStmt

Else
Set Comp = New OnComputedConstruct
Xp.FullMode = True
Set Comp.Value = Xp.GetExpression(Token, Me)
Set Token = Xp.LastToken
If Comp.Value Is Nothing Then Fail Token, Msg065

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

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

Else
Fail Token, Msg110
End If

Do
Set Token = NextToken

Select Case Token.Kind
Case tkIntegerNumber
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 Entity, ByVal Body)
Dim Stmt: Set Stmt = New OpenConstruct
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.PathName = Xp.GetExpression(, Me)
If Stmt.PathName Is Nothing Then Fail Msg120, Xp.LastToken, Msg119
If Not Xp.LastToken.IsKeyword(kwFor) Then Fail v.For, Xp.LastToken, Msg119

Dim Token: Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail , Token, Msg030

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, Msg030
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, Msg075
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 v.As, Token, Msg119
Set Stmt.FileNumber = Xp.GetExpression(, Me)
If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg119
Set Token = Xp.LastToken

If Token.IsKeyword(cxLen) Then
Set Token = NextToken
If Not Token.IsOperator(opEq) Then Fail "=", Token, Msg119

Set Stmt.Length = Xp.GetExpression(, Me)
Set Token = Xp.LastToken
End If

Body.Add , Stmt
Set ParseOpen = Token
End Function

Private Function ParsePrint(ByVal Entity, ByVal Body)
Dim Sym

Dim Stmt: Set Stmt = New PrintConstruct
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(, Me)
Dim Token: Set Token = Xp.LastToken
If Stmt.FileNumber Is Nothing Then Fail Msg110, Token, Msg121
If Token.Kind <> tkListSeparator Then Fail ",", Token, Msg121
Set Token = Nothing

Do
Dim Expr: Set Expr = Xp.GetExpression(Token, Me)
Set Token = Xp.LastToken
If Expr Is Nothing Then Fail Msg103, Xp.LastToken, Msg121

Dim Arg: Set Arg = New PrintArg

If Expr.Kind = ekIndexer Then
Dim Exec: Set Exec = Expr

If Exec.LHS.Kind = ekSymbol Then
Set Sym = Exec.LHS

If Sym.Value.Kind = tkIdentifier And Sym.Value.Code = cxSpc Then
If Exec.Arguments.Count > 1 Then Stopp 14
Set Arg.Indent = New PrintIndent
Set Arg.Indent.Value = Exec.Arguments(1)
Set Expr = Xp.GetExpression(Token, Me)
Set Token = Xp.LastToken

ElseIf Sym.Value.Kind = tkIdentifier And Sym.Value.Code = cxTab Then
If Exec.Arguments.Count > 1 Then Stopp 15
Set Arg.Indent = New PrintIndent
Arg.Indent.IsTab = True
Set Arg.Indent.Value = Exec.Arguments(1)
Set Expr = Xp.GetExpression(Token, Me)
Set Token = Xp.LastToken
End If
End If

ElseIf Expr.Kind = ekSymbol Then
Set Sym = Expr

If Sym.Value.Kind = tkIdentifier And Sym.Value.Code = cxTab Then
Set Arg.Indent = New PrintIndent
Arg.Indent.IsTab = True
Set Expr = Xp.GetExpression(Token, Me)
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 Entity, ByVal Body)
Dim Stmt: Set Stmt = New PutConstruct
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

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

If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg107
If Token.Kind <> tkListSeparator Then Fail ",", Xp.LastToken, Msg107

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

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

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

Private Function ParseRaiseEvent(ByVal Entity, ByVal Body)
Dim Stmt: Set Stmt = New RaiseEventConstruct
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

Dim ISt: Set ISt = Xp.GetStmt(, , Me)
Dim Token: Set Token = Xp.LastToken
If ISt.Kind <> snCall Then Stopp 16

Dim Exec: Set Exec = ISt
If Exec.LHS.Kind <> ekSymbol Then Stopp 17

Dim Sym: 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 Entity, ByVal Body)
Dim Var

Dim Stmt: Set Stmt = New ReDimConstruct
Dim Token: Set Token = NextToken

If Token.IsKeyword(kwPreserve) Then
Stmt.HasPreserve = True
Set Token = NextToken
End If

ParseDim Named("InsideProc:=", True), , Token, acLocal, Entity, Stmt.Vars

For Each Var In Stmt.Vars.NewEnum
If Var.HasNew Then Fail , Var.Id.Name, Msg062
If Not Var.Init Is Nothing Then Stopp 18
If Var.Subscripts.Count = 0 Then Fail , Var.Id.Name, Msg122
Next

Body.Add , Stmt
End Sub

Private Function ParseResume(ByVal Entity, ByVal Body)
Dim LinNum

Dim Stmt: Set Stmt = New ResumeConstruct
Dim Token: Set Token = NextToken

Select Case Token.Kind
Case tkIntegerNumber
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token
Set Stmt.Target = LinNum
Set Token = NextToken

Case tkIdentifier
Dim Label: 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, Msg101
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" 'TODO: It can be fooled
Set Stmt.Target = LinNum
End Select

Body.Add , Stmt
Set ParseResume = Token
End Function

Private Sub ParseSelect(ByVal Entity, ByVal Body)
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Dim Stmt: Set Stmt = New SelectConstruct

Dim Token: Set Token = NextToken
If Not Token.IsKeyword(kwCase) Then Fail v.Case, Token, Msg091

Set Stmt.Value = Xp.GetExpression(, Me)
Set Token = Xp.LastToken
If Stmt.Value Is Nothing Then Fail , Token, Msg065
If Not IsBreak(Token) Then Fail , Token, Msg031

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, Msg085 & v.Select
End If

Dim Cs: Set Cs = New CaseConstruct

Do
Dim Expr: 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
Dim IsExpr: Set IsExpr = New BinaryExpression
'IsExpr.LHS will be Nothing

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

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

Set IsExpr.RHS = Xp.GetExpression(, Me)
Set Token = Xp.LastToken
If IsExpr.RHS Is Nothing Then Fail , Token, Msg065

Set Expr = IsExpr

ElseIf Token.IsKeyword(kwElse) Then
Rem We have a "Case Else".
Set Token = ParseBody(, , Entity, Stmt.CaseElse)
If Not Token.IsKeyword(kwSelect) Then Fail , Token, Msg085 & v.Select

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

Else
Fail , Token, Msg093
End If
End If

Cs.Conditions.Add , Expr

If IsBreak(Token) Then
Set Token = ParseBody(, , Entity, Cs.Body)
Exit Do
End If

If Token.Kind <> tkListSeparator Then Fail , Token, Msg027
Loop

If Not Cs Is Nothing Then Stmt.Cases.Add , Cs
Loop Until Token.IsKeyword(kwSelect)

Body.Add , Stmt
End Sub

Private Function ParseRSet(ByVal Entity, ByVal Body)
Dim Xp: Set Xp = New Expressionist
Dim Stmt: Set Stmt = New RSetConstruct

Dim ISt: Set ISt = Xp.GetStmt(, , Me)
If ISt.Kind <> snLet Then Stopp 19

Dim Asg: Set Asg = ISt
If Asg.Name.Kind <> ekSymbol Then Stopp 20
If Asg.Operator.Value.Code <> opEq Then Fail , Asg.Operator.Value

Set Stmt.Name = Asg.Name
Set Stmt.Value = Asg.Value
Body.Add , Stmt
End Function

Private Function ParseSeek(ByVal Entity, ByVal Body)
Dim Stmt: Set Stmt = New SeekConstruct
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(, Me)
If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg123
If Xp.LastToken.Kind <> tkListSeparator Then Fail ",", Xp.LastToken, Msg123

Set Stmt.Position = Xp.GetExpression(, Me)
If Stmt.Position Is Nothing Then Fail , Xp.LastToken, Msg124

Body.Add , Stmt
Set ParseSeek = Xp.LastToken
End Function

Private Function ParseUnlock(ByVal Entity, ByVal Body)
Dim Stmt: Set Stmt = New UnlockConstruct
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(, Me)
If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg125

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

Body.Add , Stmt
Set ParseUnlock = Xp.LastToken
End Function

Private Sub ParseWhile(ByVal Entity, ByVal Body)
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Dim Stmt: Set Stmt = New WhileConstruct

Set Stmt.Condition = Xp.GetExpression(, Me)
Dim Token: Set Token = Xp.LastToken
If Stmt.Condition Is Nothing Then Fail , Token, Msg065

If Not IsBreak(Token) Then Fail , Token, Msg031
Set Token = ParseBody(, , Entity, Stmt.Body)

If Token.IsKeyword(kwWend) Then
Rem OK

ElseIf Token.IsKeyword(kwWhile) Then
Rem OK

Else
Fail , Token, Msg127
End If

MustEatLineBreak
Body.Add , Stmt
End Sub

Private Function ParseWidth(ByVal Entity, ByVal Body)
Dim Stmt: Set Stmt = New WidthConstruct
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(, Me)
If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg128
If Xp.LastToken.Kind <> tkListSeparator Then Fail ",", Xp.LastToken, Msg128

Xp.CanHaveTo = True
Set Stmt.Value = Xp.GetExpression(, Me)
If Stmt.Value Is Nothing Then Fail Msg129, Xp.LastToken, Msg128

Body.Add , Stmt
Set ParseWidth = Xp.LastToken
End Function

Private Sub ParseWith(ByVal Entity, ByVal Body)
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Dim Stmt: Set Stmt = New WithConstruct

Dim Token: Set Token = NextToken
If Not IsProperId(, Token) Then Fail Msg131, Token, Msg130

Set Stmt.PinObject = Xp.GetStmt(Token, , Me)
Set Token = Xp.LastToken
If Stmt.PinObject Is Nothing Then Fail Msg131, Token, Msg130


Set Token = ParseBody(, Named("LookAhead:=", Token), Entity, Stmt.Body)
If Not Token.IsKeyword(kwWith) Then Fail , Token, Msg132

Body.Add , Stmt
End Sub

Private Function ParseWrite(ByVal Entity, ByVal Body)
Dim Stmt: Set Stmt = New WriteConstruct
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(, Me)
Dim Token: Set Token = Xp.LastToken
If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg133
If Token.Kind <> tkListSeparator Then Fail ",", Xp.LastToken, Msg133

Do
Dim Expr: 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, ByVal RightParm)
If LeftParm.IsArray <> RightParm.IsArray Then Exit Function
If LeftParm.IsByVal <> RightParm.IsByVal Then Exit Function
If LeftParm.IsOptional <> RightParm.IsOptional Then Exit Function
If LeftParm.IsParamArray <> RightParm.IsParamArray Then Exit Function
If LeftParm.DataType.Id.Name.Code <> RightParm.DataType.Id.Name.Code Then Exit Function
AreEqual = True
End Function

Private Function SynthLower(ByVal Entity)
Dim Token: Set Token = New Token
Token.Kind = tkIntegerNumber
Token.Text = CStr(Entity.OptionBase)

Dim Lit: Set Lit = New Literal
Set Lit.Value = Token

Set SynthLower = Lit
End Function

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

Private Function SkipLineBreaks()
Dim Token

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

Set SkipLineBreaks = Token
End Function

Private Function IsId(ByVal CanHaveSuffix, ByVal Token)
If IsMissing(CanHaveSuffix) Then CanHaveSuffix = False
If Not CanHaveSuffix And Token.Suffix <> vbNullChar Then Fail , Token, Msg060
IsId = Token.Kind = tkIdentifier Or Token.Kind = tkEscapedIdentifier
End Function

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

Dim Pos
If IsMissing(CanHaveSuffix) Then CanHaveSuffix = False
If Not CanHaveSuffix And Token.Suffix <> vbNullChar Then Fail , Token, Msg060

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

If Token.Kind <> tkEscapedIdentifier Then Exit Function
Dim Text: Text = NameBank_(Token)

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

IsProperId = True
End Function

Public Function IsHardBreak(ByVal Token)
IsHardBreak = Token.Kind = tkHardLineBreak Or Token.Kind = tkComment
End Function

Public Function IsBreak(ByVal Token)
IsBreak = Token.Kind = tkSoftLineBreak Or Token.Kind = tkHardLineBreak Or Token.Kind = tkComment Or Token.Kind = tkEndOfStream
End Function

Private Function IsProperDataType(ByVal Token)
If Token.Suffix <> vbNullChar Then Fail , Token, Msg060

Select Case Token.Kind
Case tkIdentifier
IsProperDataType = True

Case tkEscapedIdentifier
IsProperDataType = IsProperId(, Token)

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

Private Function IsConstDataType(ByVal Token)
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)
Select Case Token.Code
Case cxObject, kwVariant
IsBuiltinDataType = True

Case Else
IsBuiltinDataType = IsConstDataType(Token)
End Select
End Function

Private Function IsDataType(ByVal Token)
If Token.Suffix <> vbNullChar Then Fail , Token, Msg060

If Token.IsKeyword(kwAny) Then
IsDataType = True
Exit Function
End If

IsDataType = IsProperDataType(Token)
End Function

Private Function IsEndOfContext(ByVal Token)
Dim Result: Result = IsBreak(Token)
If Not Result Then Result = Token.Kind = tkRightParenthesis
If Not Result Then Result = Token.Kind = tkListSeparator
If Not Result Then Result = Token.Kind = tkPrintSeparator

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

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

Public Sub Fail(ByVal Expected, ByVal Token, ByVal Message)
Dim Ch, Msg, Got, Text

If IsMissing(Expected) Then Expected = ""

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

Case tkFileHandle, tkDirective
Got = "#" & NameBank_(Token)

Case tkWhiteSpace
Got = " "

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

Case tkLeftParenthesis
Got = "("

Case tkRightParenthesis
Got = ")"

Case tkHardLineBreak
Got = "line-break"

Case tkLineContinuation
Got = "line-continuation"

Case tkEndOfStream
Got = "end-of-stream"

Case tkSoftLineBreak
Got = ":"

Case tkListSeparator
Got = ","

Case tkPrintSeparator
Got = ";"

Case Else
Got = NameBank_(Token)
End Select

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

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

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

Private Function FromChar(ByVal TypeDeclarationChar)
Dim 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
MsgBox "Should not happen (4)"
Err.Raise 5
End Select

Set FromChar = NewDataType(Token)
End Function

Private Sub CheckDupl(ByVal JumpProp, ByVal Entity, ByVal Token)
If IsMissing(JumpProp) Then JumpProp = False
Dim Name: Name = NameBank_(Token)

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

Class PrintArg
Public Indent
Public Value
Public HasSemicolon

Private Sub Class_Initialize()
Set Indent = Nothing
Set Value = Nothing
End Sub
End Class

Class PrintConstruct
Public Output
Public FileNumber

Private Sub Class_Initialize()
Set Output = New KeyedList
Set FileNumber = Nothing
End Sub

Public Property Get Kind()
Kind = snPrint
End Property
End Class

Class PrintIndent
Public IsTab
Public Value

Private Sub Class_Initialize()
Set Value = Nothing
End Sub
End Class

Class PropertyConstruct
Public Parameters
Public Body
Public Access
Public IsStatic
Public IsDefault

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

Set Body = New KeyedList
End Sub
End Class

Class PropertySlot
Private PropertyGet_
Private PropertyLet_
Private PropertySet_

Public Id
Public DataType

Private Sub Class_Initialize()
Set PropertyGet_ = Nothing
Set PropertyLet_ = Nothing
Set PropertySet_ = Nothing
Set Id = Nothing
Set DataType = Nothing
End Sub

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

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

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

Case Else
MsgBox "Should not happen (5)"
Err.Raise 5
End Select
End Sub

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

Case VbLet
Set Item = PropertyLet_

Case VbSet
Set Item = PropertySet_

Case Else
MsgBox "Should not happen (6)"
Err.Raise 5
End Select
End Property

Public Property Get Exists(ByVal Kind)
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
MsgBox "Should not happen (7)"
Err.Raise 5
End Select
End Property
End Class

Class PutConstruct
Public FileNumber
Public RecNumber
Public Var

Private Sub Class_Initialize()
Set FileNumber = Nothing
Set RecNumber = Nothing
Set Var = Nothing
End Sub

Public Property Get Kind()
Kind = snPut
End Property
End Class

Class RaiseEventConstruct
Public Arguments
Public Id

Private Sub Class_Initialize()
Set Arguments = New KeyedList
Set Id = Nothing
End Sub

Public Property Get Kind()
Kind = snRaiseEvent
End Property
End Class

Class ReDimConstruct
Public Vars
Public HasPreserve

Private Sub Class_Initialize()
Set Vars = New KeyedList
End Sub

Public Property Get Kind()
Kind = snReDim
End Property
End Class

Class ResetConstruct
Public Property Get Kind()
Kind = snReset
End Property
End Class

Class ResumeConstruct
Public IsNext
Public Target

Private Sub Class_Initialize()
Set Target = Nothing
End Sub

Public Property Get Kind()
Kind = snResume
End Property
End Class

Class ReturnConstruct
Public Property Get Kind()
Kind = snReturn
End Property
End Class

Class Reverter
Public Builder

Public Sub Transpile(ByVal Source)
Dim Idx, Ent

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

Private Sub EmitEntity(ByVal Entity)
Dim Sep, Count

Dim Def: Set Def = Nothing
Dim Var: Set Var = Nothing
Dim Slt: Set Slt = Nothing
Dim Prc: Set Prc = Nothing
Dim Typ: Set Typ = Nothing
Dim Enm: Set Enm = Nothing
Dim Evt: Set Evt = Nothing
Dim Cnt: Set Cnt = Nothing
Dim Dcl: Set Dcl = Nothing
Dim Fnc: Set Fnc = Nothing
Dim Prp: Set Prp = Nothing
Dim Ipl: Set Ipl = Nothing

With Builder
EmitAccess Entity.Accessibility
.Append IIf(Entity.IsClass, "Class ", "Module ")
EmitId Entity.Id
.AppendLn ""
.Indent

.Append "Option Base "
.AppendLn Entity.OptionBase

.Append "Option Compare "
.AppendLn IIf(Entity.OptionCompare = vbBinaryCompare, "Binary", "Text")

If Entity.OptionExplicit Then .AppendLn "Option Explicit"
.AppendLn ""

For Each Ipl In Entity.Impls.NewEnum
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.NewEnum
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.NewEnum
EmitType Typ
.AppendLn ""

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

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

For Each Var In Entity.Vars.NewEnum
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.NewEnum
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.NewEnum
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.NewEnum
EmitEnum Enm
.AppendLn ""

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

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

Count = 0

For Each Fnc In Entity.Functions.NewEnum
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
EmitBody Fnc.Body
.Deindent
.AppendLn "End Function"

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

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

Count = 0

For Each Prc In Entity.Subs.NewEnum
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
EmitBody Prc.Body
.Deindent
.AppendLn "End Sub"
Sep = True
Count = Count + 1
If Count <> Entity.Subs.Count Then .AppendLn ""
Next

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

Count = 0

For Each Slt In Entity.Properties.NewEnum
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
EmitBody Prp.Body
.Deindent
.AppendLn "End Property"

If Slt.Exists(VbLet) Or Slt.Exists(VbSet) Then .AppendLn ""
End If

If Slt.Exists(VbLet) Then
Set Prp = Slt(VbLet)
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 = 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 EmitAccess(ByVal Access)
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)
Builder.Append "Implements "
EmitId Ipl.Id
End Sub

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

Private Sub EmitId(ByVal Id)
If Not Id.Project Is Nothing Then
EmitToken Id.Project
Builder.Append "."
End If

EmitToken Id.Name
End Sub

Private Sub EmitParams(ByVal Params)
Dim Idx, Parm

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 Not Parm.Init Is 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)
EmitId DataType.Id

If Not DataType.FixedLength Is Nothing Then
Builder.Append " * "
EmitExpression , DataType.FixedLength
End If
End Sub

Private Sub EmitType(ByVal Typ)
Dim Mem

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

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

If Mem.DataType.IsArray And 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)
Dim Idx, Pair

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)
If Cnt.Access = acLocal Then Builder.Deindent

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

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

If Not Cnt.Value Is Nothing Then
Builder.Append " = "
EmitExpression , Cnt.Value
End If

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

Private Sub EmitDeclare(ByVal Dcl)
EmitAccess Dcl.Access
Builder.Append "Declare "
'->Builder.Append "SafePtr "
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 Not Dcl.AliasName Is 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)
Dim Mem

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

For Each Mem In Enm.Enumerands.NewEnum
EmitId Mem.Id

If Not Mem.Value Is Nothing Then
Builder.Append " = "
EmitExpression , Mem.Value
End If

Builder.AppendLn ""
Next

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

Private Sub EmitExpression(ByVal Op, ByVal Expr)
Dim Par, Idx

If IsMissing(Op) Then Set Op = Nothing
Dim Sym: Set Sym = Nothing
Dim Lit: Set Lit = Nothing
Dim Hnd: Set Hnd = Nothing
Dim Exr: Set Exr = Nothing
Dim Tup: Set Tup = Nothing
Dim Uni: Set Uni = Nothing
Dim Bin: Set Bin = Nothing

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 Not Op Is Nothing Then Par = ComparePrecedence(Op, Bin.Operator) = 1
If Par Then Builder.Append "("

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

If Par Then Builder.Append ")"

Case ekIndexer
EmitCall Expr
End Select
End Sub

Private Sub EmitBody(ByVal Body)
Dim Stmt

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

Private Sub EmitStmt(ByVal Stmt)
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)
Dim Count, Expr

EmitExpression , Stmt.LHS

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

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

Builder.Append ")"
End If
End Sub

Private Sub EmitClose(ByVal Stmt)
Dim Number

Builder.Append "Close"

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

Private Sub EmitContinue(ByVal Stmt)
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)
Stopp 21
End Sub

Private Sub EmitDim(ByVal Stmt)
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 Not Stmt.Init Is Nothing Then
Builder.Append " = "
EmitExpression , Stmt.Init
End If

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

Private Sub EmitDo(ByVal Stmt)
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)
Builder.Append "End"
End Sub

Private Sub EmitErase(ByVal Stmt)
Dim Count, Var

Builder.Append "Erase "

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

Builder.Append " "
End Sub

Private Sub EmitExit(ByVal Stmt)
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)
Dim Lit, HasStep

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 Or 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)
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)
Builder.Append "Get "
EmitExpression , Stmt.FileNumber
Builder.Append ", "
If Not Stmt.RecNumber Is Nothing Then EmitExpression , Stmt.RecNumber
Builder.Append ", "
EmitToken Stmt.Var.Value
End Sub

Private Sub EmitGoSub(ByVal Stmt)
Builder.Append "GoSub "

If Stmt.Target.Kind = snLineNumber Then
Dim LinNum: Set LinNum = Stmt.Target
EmitToken LinNum.Value
Else
Dim Label: Set Label = Stmt.Target
EmitId Label.Id
End If
End Sub

Private Sub EmitGoTo(ByVal Stmt)
Builder.Append "GoTo "

If Stmt.Target.Kind = snLineNumber Then
Dim LinNum: Set LinNum = Stmt.Target
EmitToken LinNum.Value
Else
Dim Label: Set Label = Stmt.Target
EmitId Label.Id
End If
End Sub

Private Sub EmitIf(ByVal Stmt)
Dim Arm, Idx

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 Sub

Private Sub EmitInput(ByVal Stmt)
Dim Count, Var

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

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

Private Sub EmitLabel(ByVal Stmt)
Builder.Append NameBank_(Stmt.Id.Name)
Builder.Append ": "
End Sub

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

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

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

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

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

Private Sub EmitOnError(ByVal Stmt)
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)
Dim Count, Target, Label

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.NewEnum
If Target.Kind = snLabel Then
Set Label = Target
EmitId Label.Id
Else
EmitLineNumber Target
End If

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

Private Sub EmitOpen(ByVal Stmt)
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 Not Stmt.Length Is Nothing Then
Builder.Append " Len="
EmitExpression , Stmt.Length
End If
End Sub

Private Sub EmitPrint(ByVal Stmt)
Dim Count, Arg

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

For Each Arg In Stmt.Output.NewEnum
Count = Count + 1

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

If Not Arg.Indent.Value Is Nothing Then
Builder.Append "("
EmitExpression , Arg.Indent.Value
Builder.Append ")"
End If

Builder.Append " "
End If

EmitExpression , Arg.Value

If Arg.HasSemicolon Then
Builder.Append ";"
Else
If Count <> Stmt.Output.Count Then Builder.Append " "
End If
Next
End Sub

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

Private Sub EmitRaiseEvent(ByVal Stmt)
Dim Count, Expr

Builder.Append "RaiseEvent "
EmitId Stmt.Id

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

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

Builder.Append ")"
End If

Builder.Append " "
End Sub

Private Sub EmitReDim(ByVal Stmt)
Dim Count, Var

Builder.Append "ReDim "
If Stmt.HasPreserve Then Builder.Append "Preserve "

For Each Var In Stmt.Vars.NewEnum
EmitId Var.Id
EmitSubscripts Var.Subscripts
Builder.Append " As "
EmitDataType Var.DataType
Count = Count + 1
If Count <> Stmt.Vars.Count Then Builder.Append ", "
Next
End Sub

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

Private Sub EmitResume(ByVal Stmt)
Builder.Append "Resume"

If Stmt.IsNext Then
Builder.Append " Next "

ElseIf Stmt.Target.Kind = snLabel Then
Builder.Append " "
Dim Label: Set Label = Stmt.Target
EmitId Label.Id
Else
Dim LinNum: 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)
Builder.Append "Return "
End Sub

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

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

Private Sub EmitSelect(ByVal Stmt)
Dim Count, Cond, Cs, Bin

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

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

For Each Cond In Cs.Conditions.NewEnum
Count = 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)
Builder.Append "Set "
EmitExpression , Stmt.Name
Builder.Append " = "
EmitExpression , Stmt.Value
End Sub

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

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

Private Sub EmitWhile(ByVal Stmt)
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)
Builder.Append "Width "
EmitExpression , Stmt.FileNumber
Builder.Append ", "
EmitExpression , Stmt.Value
End Sub

Private Sub EmitWith(ByVal Stmt)
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)
Dim Count, Expr

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

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

Private Sub EmitToken(ByVal Stmt)
Select Case Stmt.Kind
Case tkBinaryNumber
Builder.Append "&B"
Builder.Append Stmt.Text

Case tkDateTime
Builder.Append "#"
Builder.Append Stmt.Text
Builder.Append "#"

Case tkEscapedIdentifier
Builder.Append "["
Builder.Append Stmt.Text
Builder.Append "]"

Case tkFileHandle, tkFloatNumber, tkIntegerNumber, tkSciNumber
Builder.Append Stmt.Text

Case tkHexaNumber
Builder.Append "&H"
Builder.Append Stmt.Text

Case tkIdentifier, tkKeyword
Builder.Append NameBank_(Stmt)

Case tkOperator
Builder.Append Replace(NameBank_(Stmt), "~", "")

Case tkOctalNumber
Builder.Append "&O"
Builder.Append Stmt.Text

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)
If Stmt.IsUnary Then
EmitToken Stmt.Value

Select Case Stmt.Value.Code
Case opWithBang, opWithDot, opNeg
Rem OK

Case Else
Builder.Append " "
End Select

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

Case Else
Builder.Append " "
EmitToken Stmt.Value
Builder.Append " "
End Select
End If
End Sub
End Class

Class RSetConstruct
Public Name
Public Value

Private Sub Class_Initialize()
Set Name = Nothing
Set Value = Nothing
End Sub

Public Property Get Kind()
Kind = snRSet
End Property
End Class

Class SeekConstruct
Public FileNumber
Public Position

Private Sub Class_Initialize()
Set FileNumber = Nothing
Set Position = Nothing
End Sub

Public Property Get Kind()
Kind = snSeek
End Property
End Class

Class SelectConstruct
Public Cases
Public CaseElse
Public Value

Private Sub Class_Initialize()
Set Cases = New KeyedList
Set CaseElse = New KeyedList
Set Value = Nothing
End Sub

Public Property Get Kind()
Kind = snSelect
End Property
End Class

Class SetConstruct
Public Name
Public Value

Private Sub Class_Initialize()
Set Name = Nothing
Set Value = Nothing
End Sub

Public Property Get Kind()
Kind = snSet
End Property
End Class

Class SourceFile
Public Entities
Public Path

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

Class StopConstruct
Public Property Get Kind()
Kind = snStop
End Property
End Class

Class SubConstruct
Public Parameters
Public Body
Public Access
Public IsStatic
Public IsDefault
Public Id

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

Set Body = New KeyedList
Set Id = Nothing
End Sub
End Class

Class SubscriptPair
Private UpperBound_

Public LowerBound

Private Sub Class_Initialize()
Set UpperBound_ = Nothing
Set LowerBound = Nothing
End Sub

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

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

Class Symbol
Public Value

Private Sub Class_Initialize()
Set Value = Nothing
End Sub

Public Property Get Kind()
Kind = ekSymbol
End Property
End Class

Class Token
Public Code
Public Line
Public Column
Public Spaces
Public Text
Public Suffix
Public Kind

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

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

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

Class TupleConstruct
Public Elements

Private Sub Class_Initialize()
Set Elements = New KeyedList
End Sub

Public Property Get Kind()
Kind = ekTuple
End Property
End Class

Class TypeConstruct
Public Members
Public Access
Public Id

Private Sub Class_Initialize()
Set Members = New KeyedList
Members.CompareMode = vbTextCompare
Set Id = Nothing
End Sub
End Class

Class UnaryExpression
Public Operator
Public Value

Private Sub Class_Initialize()
Set Operator = Nothing
Set Value = Nothing
End Sub

Public Property Get Kind()
Kind = ekUnaryExpr
End Property
End Class

Class UnlockConstruct
Public FileNumber
Public RecordRange

Private Sub Class_Initialize()
Set FileNumber = Nothing
Set RecordRange = Nothing
End Sub

Public Property Get Kind()
Kind = snUnlock
End Property
End Class

Class Variable
Private Id_

Public Subscripts
Public IsStatic
Public HasWithEvents
Public HasNew
Public DataType
Public Init
Public Access

Private Sub Class_Initialize()
Set Subscripts = New KeyedList
Set Id_ = New Identifier
Set DataType = Nothing
Set Init = Nothing
End Sub

Public Property Get Id()
Set Id = Id_
End Property

Public Property Get Kind()
Kind = snDim
End Property
End Class

Class WhileConstruct
Public Body
Public Condition

Private Sub Class_Initialize()
Set Body = New KeyedList
Set Condition = Nothing
End Sub

Public Property Get Kind()
Kind = snWhile
End Property
End Class

Class WidthConstruct
Public FileNumber
Public Value

Private Sub Class_Initialize()
Set FileNumber = Nothing
Set Value = Nothing
End Sub

Public Property Get Kind()
Kind = snWidth
End Property
End Class

Class WithConstruct
Public Body
Public PinObject

Private Sub Class_Initialize()
Set Body = New KeyedList
Set PinObject = Nothing
End Sub

Public Property Get Kind()
Kind = snWith
End Property
End Class

Class WriteConstruct
Public Output
Public FileNumber

Private Sub Class_Initialize()
Set Output = New KeyedList
Set FileNumber = Nothing
End Sub

Public Property Get Kind()
Kind = snWrite
End Property
End Class

Sub Stopp(n)
MsgBox "Stop=" & n
End Sub

'ForwardCompatibility
Const vbLongLong = 20
Const vbLongPtr = 37

'Globals
Dim v: Set v = New Vocabulary
Dim NameBank_: Set NameBank_ = New NameBank

Function NewId(ByVal Token)
Dim Result: Set Result = New Identifier
Set Result.Name = Token
Set NewId = Result
End Function

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

Public Function NewOperator(ByVal Token)
Dim Result: Set Result = New Operator
Set Result.Value = Token
Set NewOperator = Result
End Function

Public Function SizeOf(ByVal VariableType)
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
SizeOf = 4

Case kwVariant
SizeOf = 16
End Select
End Function

Public Function ComparePrecedence(ByVal LeftOp, ByVal RightOp)
Dim LHS: LHS = Precedence(LeftOp)
Dim RHS: RHS = Precedence(RightOp)

If LHS = RHS Then Exit Function

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

Private Function Precedence(ByVal Op)
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
End Select
End Function

'Messages
Const Msg001 = "Public, Private, Class, or Module"
Const Msg002 = "Class or Module"
Const Msg003 = "identifier"
Const Msg004 = "Rule: End (Class | Module)"
Const Msg005 = "Rule: vbCr | vbLf | vbCrLf | : | '"
Const Msg006 = "Ambiguous name detected: "
Const Msg007 = "Rule: [Public | Private] (Class | Module) identifier"
Const Msg008 = "Rule: [Public | Private] identifier"
Const Msg010 = "Duplicated Option statement"
Const Msg011 = "Rule: Option Base (0 | 1)"
Const Msg012 = "Rule: [Public] Event identifier [([parms])]"
Const Msg013 = "Rule: Option Compare (Binary | Text)"
Const Msg014 = "Binary or Text"
Const Msg015 = "Rule: Option (Base | Compare | Explicit)"
Const Msg016 = "Only valid inside Class"
Const Msg017 = "Event can only be Public"
Const Msg018 = "Expected: Option or Deftype or Public or Private or Const or Enum or Declare or Type"
Const Msg019 = "Rule: DefType first[-last] [, ...]"
Const Msg020 = "first"
Const Msg021 = "last"
Const Msg022 = "Duplicated Deftype statement"
Const Msg023 = "Rule: [Public | Private] Const identifier [As datatype] = expression [, ...]"
Const Msg024 = "Identifier already has a type-declaration character"
Const Msg025 = "datatype"
Const Msg026 = "Fixed-length allowed only for String"
Const Msg027 = "list separator or end of statement"
Const Msg028 = "Rule: [Public | Private] Enum identifier"
Const Msg029 = "Enum cannot have a type-declaration character"
Const Msg030 = "Expected: Append or Binary or Input or Random"
Const Msg031 = "End of statement"
Const Msg032 = "Rule: identifier [= expression]"
Const Msg033 = "Enum member cannot have a type-declaration character"
Const Msg034 = "Rule: End Enum"
Const Msg035 = "Enum without members is not allowed"
Const Msg036 = "Rule: [Public | Private] Declare (Sub | Function) identifier [CDecl] Lib lib_string [Alias alias_string] ([parms]) [As data_type[()]]"
Const Msg037 = "Sub or Function"
Const Msg038 = "lib string"
Const Msg039 = "alias string"
Const Msg040 = "Duplicated declaration in current scope"
Const Msg041 = "Rule: [[Optional] (ByVal | ByRef) | ParamArray] identifier[type_declaration_char][()] [As data_type] [:= expression]"
Const Msg042 = "Too many formal parameters"
Const Msg043 = "Cannot have both Optional and ParamArray parameters"
Const Msg044 = "Optional not allowed"
Const Msg045 = "ParamArray not allowed"
Const Msg046 = "ByVal not allowed"
Const Msg047 = "ByRef not allowed"
Const Msg048 = "ParamArray parameter must be an array"
Const Msg049 = "Identifier already has a type-declaration character"
Const Msg050 = "As [project_name.]identifier"
Const Msg051 = "ParamArray must be an array of Variants"
Const Msg052 = "Sub, Property Let, or Property Get cannot have an As clause"
Const Msg053 = "Parameter is not Optional"
Const Msg054 = "ParamArray cannot have a default value"
Const Msg057 = "Unclosed parenthesis"
Const Msg058 = "Rule: Implements [project_name.]identifier"
Const Msg059 = "Project name or identifier"
Const Msg060 = "Type-declaration character not allowed here"
Const Msg061 = "(Public | Private | Static | Dim) [WithEvents] identifier[type_declaration_character][([[n To] m[, ...]])] [As (data_type [= expression] | New class_name)] [, ...]"
Const Msg062 = "Invalid use of New"
Const Msg063 = "Invalid inside Sub, Function, or Property"
Const Msg064 = "Invalid use of New with array"
Const Msg065 = "Invalid expression"
Const Msg067 = "Rule: member_name As data_type"
Const Msg068 = "Rule: End Type"
Const Msg069 = "Rule: [Public | Private | Friend] [Static] [Default] Sub identifier[([parms])]"
Const Msg070 = "Rule: [Public | Private | Friend] [Static] [Default] Function identifier[type_declaration_character][()][([parms])] [As datatype[()]]"
Const Msg071 = "Rule: [Public | Private | Friend] [Static] [Default] Property (Get | Let | Set) identifier[type_declaration_character][()][([parms])] [As datatype[()]]"
Const Msg072 = "Rule: End Sub"
Const Msg073 = "Rule: End Function"
Const Msg074 = "Rule: End Property"
Const Msg075 = "Expected: Read or Write"
Const Msg076 = "Get or Let or Set"
Const Msg077 = "Definitions of property procedures for the same property are inconsistent, or property procedure has an optional parameter, a ParamArray, or an invalid Set final parameter"
Const Msg078 = "Argument required for Property Let or Property Set"
Const Msg079 = "Rule: (Public | Private | Friend) identifier"
Const Msg080 = "Duplicated Static statement"
Const Msg081 = "Duplicated Iterator statement"
Const Msg082 = "Duplicated Default statement"
Const Msg083 = "A Function cannot be both Default and Iterator"
Const Msg084 = "Expected: = or argument"
Const Msg085 = "Expected: End "
Const Msg086 = "Expected: Get or Let or Set"
Const Msg087 = "Expected: statement"
Const Msg088 = "Rule: If condition Then"
Const Msg089 = "Expected: Else or ElseIf or End If"
Const Msg090 = "Block If without End If"
Const Msg091 = "Rule: Select Case expression"
Const Msg092 = "Expected: > or >= or = or < or <= or <>"
Const Msg093 = "Expected: Is or Else"
Const Msg094 = "Expected: = or argument"
Const Msg095 = "Expected: Do or For or While"
Const Msg096 = "Expected: Loop"
Const Msg097 = "Rule: Erase identifier"
Const Msg098 = "Expected: Do or For or Function or Property or Sub or Select or While"
Const Msg099 = "Rule: For identifier = start To end [Step increment]"
Const Msg100 = "increment"
Const Msg101 = "Expected: Next"
Const Msg102 = "Rule: For Each variable In group"
Const Msg103 = "variable"
Const Msg104 = "group"
Const Msg105 = "Rule: Get [#]filenumber, [recnumber], varname"
Const Msg107 = "Rule: Put [#]filenumber, [recnumber], varname"
Const Msg108 = "Expected: Label or line number"
Const Msg109 = "Rule: Input #filenumber, variable[, variable, ...]"
Const Msg110 = "#filenumber"
Const Msg112 = "Lock [#]filenumber[, recordrange]"
Const Msg113 = "recordrange"
Const Msg114 = "Rule: LSet variable = value"
Const Msg115 = "Rule: Name oldpathname As newpathname"
Const Msg116 = "oldpathname"
Const Msg117 = "newpathname"
Const Msg118 = "Expected: GoTo or Resume"
Const Msg119 = "Rule: Open pathname For mode [Access access] [lock] As [#]filenumber [Len=reclength]"
Const Msg120 = "pathname"
Const Msg121 = "Print #filenumber, [outputlist]"
Const Msg122 = "Expected: subscript"
Const Msg123 = "Rule: Seek [#]filenumber, position"
Const Msg124 = "position"
Const Msg125 = "Rule: Unlock [#]filenumber[, recordrange]"
Const Msg126 = "Rule: While condition"
Const Msg127 = "Expected: Wend or End While"
Const Msg128 = "Rule: Width #filenumber, width"
Const Msg129 = "width"
Const Msg130 = "Rule: With object"
Const Msg131 = "object"
Const Msg132 = "Expected: End With"
Const Msg133 = "Rule: Write #filenumber, [outputlist]"

'Vocabulary
Class Vocabulary
Rem Contextual in VB6
Public Property Get Access()
Access = "Access"
End Property

Public Property Get [AddressOf]()
[AddressOf] = "AddressOf"
End Property

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

Public Property Get [And]()
[And] = "And"
End Property

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

Public Property Get [Any]()
[Any] = "Any"
End Property

Rem Contextual in VB6
Public Property Get Append()
Append = "Append"
End Property

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

Public Property Get [Attribute]()
[Attribute] = "Attribute"
End Property

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

Rem Contextual in VB6
Public Property Get Binary()
Binary = "Binary"
End Property

Public Property Get [Boolean]()
[Boolean] = "Boolean"
End Property

Public Property Get [ByRef]()
[ByRef] = "ByRef"
End Property

Public Property Get [ByVal]()
[ByVal] = "ByVal"
End Property

Public Property Get [Byte]()
[Byte] = "Byte"
End Property

Public Property Get [Call]()
[Call] = "Call"
End Property

Public Property Get [Case]()
[Case] = "Case"
End Property

Public Property Get CDecl()
CDecl = "CDecl"
End Property

Public Property Get [Circle]()
[Circle] = "Circle"
End Property

Rem New!
Public Property Get [Class]()
[Class] = "Class"
End Property

Public Property Get [Close]()
[Close] = "Close"
End Property

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

Public Property Get [Const]()
[Const] = "Const"
End Property

Rem New!
Public Property Get Continue()
Continue = "Continue"
End Property

Public Property Get [Currency]()
[Currency] = "Currency"
End Property

Public Property Get [Date]()
[Date] = "Date"
End Property

Public Property Get [Decimal]()
[Decimal] = "Decimal"
End Property

Public Property Get [Debug]()
[Debug] = "Debug"
End Property

Public Property Get [Declare]()
[Declare] = "Declare"
End Property

Rem New!
Public Property Get [Default]()
[Default] = "Default"
End Property

Public Property Get [DefBool]()
[DefBool] = "DefBool"
End Property

Public Property Get [DefByte]()
[DefByte] = "DefByte"
End Property

Public Property Get [DefCur]()
[DefCur] = "DefCur"
End Property

Public Property Get [DefDate]()
[DefDate] = "DefDate"
End Property

Public Property Get [DefDbl]()
[DefDbl] = "DefDbl"
End Property

Public Property Get [DefDec]()
[DefDec] = "DefDec"
End Property

Public Property Get [DefInt]()
[DefInt] = "DefInt"
End Property

Public Property Get [DefLng]()
[DefLng] = "DefLng"
End Property

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

Rem New!
Public Property Get DefLngPtr()
DefLngPtr = "DefLngPtr"
End Property

Public Property Get [DefObj]()
[DefObj] = "DefObj"
End Property

Public Property Get [DefSng]()
[DefSng] = "DefSng"
End Property

Public Property Get [DefStr]()
[DefStr] = "DefStr"
End Property

Public Property Get [DefVar]()
[DefVar] = "DefVar"
End Property

Public Property Get [Dim]()
[Dim] = "Dim"
End Property

Public Property Get [Do]()
[Do] = "Do"
End Property

Public Property Get [Double]()
[Double] = "Double"
End Property

Public Property Get [Each]()
[Each] = "Each"
End Property

Public Property Get [ElseIf]()
[ElseIf] = "ElseIf"
End Property

Public Property Get [Else]()
[Else] = "Else"
End Property

Public Property Get [Empty]()
[Empty] = "Empty"
End Property

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

Public Property Get [EndIf]()
[EndIf] = "EndIf"
End Property

Public Property Get [Enum]()
[Enum] = "Enum"
End Property

Public Property Get [Eqv]()
[Eqv] = "Eqv"
End Property

Public Property Get [Erase]()
[Erase] = "Erase"
End Property

Rem Contextual in VB6
Public Property Get Error()
Error = "Error"
End Property

Public Property Get [Event]()
[Event] = "Event"
End Property

Public Property Get [Exit]()
[Exit] = "Exit"
End Property

Rem Contextual in VB6
Public Property Get Explicit()
Explicit = "Explicit"
End Property

Public Property Get [False]()
[False] = "False"
End Property

Public Property Get [For]()
[For] = "For"
End Property

Public Property Get [Friend]()
[Friend] = "Friend"
End Property

Public Property Get [Function]()
[Function] = "Function"
End Property

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

Public Property Get [Global]()
[Global] = "Global"
End Property

Public Property Get [GoSub]()
[GoSub] = "GoSub"
End Property

Public Property Get [GoTo]()
[GoTo] = "GoTo"
End Property

Public Property Get [If]()
[If] = "If"
End Property

Public Property Get [Imp]()
[Imp] = "Imp"
End Property

Public Property Get [Implements]()
[Implements] = "Implements"
End Property

Public Property Get [In]()
[In] = "In"
End Property

Public Property Get [Input]()
[Input] = "Input"
End Property

Public Property Get [Integer]()
[Integer] = "Integer"
End Property

Public Property Get [Is]()
[Is] = "Is"
End Property

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

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

Public Property Get [Let]()
[Let] = "Let"
End Property

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

Public Property Get [Like]()
[Like] = "Like"
End Property

Rem Contextual in VB6
Public Property Get Line()
Line = "Line"
End Property

Public Property Get [Lock]()
[Lock] = "Lock"
End Property

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

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

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

Rem New!
Public Property Get LongLong()
LongLong = "LongLong"
End Property

Public Property Get [Loop]()
[Loop] = "Loop"
End Property

Public Property Get [LSet]()
[LSet] = "LSet"
End Property

Public Property Get [Len]()
[Len] = "Len"
End Property

Public Property Get [Me]()
[Me] = "Me"
End Property

Public Property Get [Mod]()
[Mod] = "Mod"
End Property

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

Rem Contextual in VB6
Public Property Get Name()
Name = "Name"
End Property

Public Property Get [New]()
[New] = "New"
End Property

Public Property Get [Next]()
[Next] = "Next"
End Property

Public Property Get [Not]()
[Not] = "Not"
End Property

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

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

Rem Contextual in VB6
Public Property Get Object()
Object = "Object"
End Property

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

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

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

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

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

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

Rem Contextual in VB6
Public Property Get Output()
Output = "Output"
End Property

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

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

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

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

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

Public Property Get Property()
Property = "Property"
End Property

Rem New!
Public Property Get PtrSafe()
PtrSafe = "PtrSafe"
End Property

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

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

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

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

Rem Contextual in VB6
Public Property Get Read()
Read = "Read"
End Property

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

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

Rem Contextual in VB6
Public Property Get Reset()
Reset = "Reset"
End Property

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

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

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

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

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

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

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

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

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

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

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

Rem Contextual in VB6
Public Property Get Step()
Step = "Step"
End Property

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

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

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

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

Rem Contextual in VB6
Public Property Get Text()
Text = "Text"
End Property

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

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

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

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

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

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

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

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

Public Property Get Void()
Void = ""
End Property

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

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

Rem Contextual in VB6
Public Property Get Width()
Width = "Width"
End Property

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

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

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

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

'VBScript specifics
Function Named(Name, Value)
If IsObject(Value) Then Set Named = Value Else Named = Value
End Function

Function IIf(Expression, TruePart, FalsePart)
If Expression Then
If IsObject(TruePart) Then Set IIf = TruePart Else IIf = TruePart
Else
If IsObject(FalsePart) Then Set IIf = FalsePart Else IIf = FalsePart
End If
End Function

Function IsMissing(Value)
IsMissing = VarType(Value) = vbError
End Function

Function Switch(Test1, Value1, Test2, Value2, Test3, Value3)
Switch = Value1
If Test1 Then Exit Function

Switch = Value2
If Test2 Then Exit Function

Switch = Value3
If Test3 Then Exit Function

Switch = Null
End Function

'StringCentral
Const NO_OF_COLS = 5

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

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

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

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

Public Function IsSpace(ByVal CodePoint)
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
IsSpace = True

Case Else
IsSpace = CodePoint >= EN_QUAD And CodePoint <= HAIR_SPACE
End Select
End Function

'Program
Private Const SPAN_STRING = "<span style='color:brown;'>"
Private Const SPAN_KEYWORD = "<span style='color:blue;'>"
Private Const SPAN_COMMENT = "<span style='color: green;'>"

Public Sub Main()
Dim Source: Set Source = New SourceFile
Source.Path = WScript.Arguments(0)

Dim Parser: Set Parser = New Parser
Parser.Parse Source

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

Dim Revert: Set Revert = New Reverter
Set Revert.Builder = Builder
Revert.Transpile Source
End Sub

Public Sub PrettyPrint()
Dim HtmlFile, Text, Token

Rem File path for the source code is passed as a command-line argument.
Dim Source: Set Source = New SourceFile
Dim FilePath: FilePath = WScript.Arguments(0)
Source.Path = FilePath

Dim Parser: 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: Index = InStrRev(FilePath, ".")
If Index <> 0 Then FilePath = Left(FilePath, Index - 1)

FilePath = FilePath & ".html"

With CreateObject("Scripting.FileSystemObject")
Set HtmlFile = .OpenTextFile(FilePath, ForWriting, Named("Create:=", True), Named("Format:=Unicode", True))
End With

Dim Nbsp: Nbsp = True

Do
Set Token = Parser.NextTokenForPrint

If Nbsp Then
For Index = 1 To Token.Spaces
HtmlFile.Access "&nbsp;&nbsp;&nbsp;&nbsp;"
Next
Else
HtmlFile.Access Space(Token.Spaces)
End If

Select Case Token.Kind
Case tkComment
HtmlFile.Access SPAN_COMMENT & EncodeHtml(Token.Text) & "</span><br>"
Nbsp = True

Case tkIdentifier
HtmlFile.Access NameBank_(Token)
Nbsp = False

Case tkIntegerNumber, tkFloatNumber, tkSciNumber
HtmlFile.Access Token.Text
Nbsp = False

Case tkEscapedIdentifier
HtmlFile.Access "[" & Token.Text & "]"
Nbsp = False

Case tkKeyword
HtmlFile.Access SPAN_KEYWORD & NameBank_(Token) & "</span>"
Nbsp = False

Case tkOctalNumber
HtmlFile.Access "&amp;O" & Token.Text

Case tkHexaNumber
HtmlFile.Access "&amp;H" & UCase(Token.Text)

Case tkFileHandle
HtmlFile.Access "#" & Token.Text

Case tkString
Text = Token.Text
Text = Replace(Token.Text, """", """""")
Text = EncodeHtml(Text)
HtmlFile.Access SPAN_STRING & """" & Text & """</span>"

Case tkDateTime
HtmlFile.Access "#" & Token.Text & "#"

Case tkOperator
If IsLetter(AscW(NameBank_(Token))) Then
HtmlFile.Access SPAN_KEYWORD & NameBank_(Token) & "</span>"

ElseIf Left(NameBank_(Token), 1) = "" ~Then
HtmlFile.Access Mid(NameBank_(Token), 2)

Else
HtmlFile.Access EncodeHtml(NameBank_(Token))
End If

Case tkLeftParenthesis
HtmlFile.Access "("
Nbsp = False

Case tkRightParenthesis
HtmlFile.Access ")"
Nbsp = False

Case tkListSeparator
HtmlFile.Access ","
Nbsp = False

Case tkSoftLineBreak
HtmlFile.Access ":"
Nbsp = False

Case tkPrintSeparator
HtmlFile.Access ";"
Nbsp = False

Case tkLineContinuation
HtmlFile.WriteLine "&nbsp;_<br>"
Nbsp = True

Case tkHardLineBreak
HtmlFile.WriteLine "<br />"
Nbsp = True

Case tkDirective
HtmlFile.Access "#" & Token.Text
Nbsp = False

Case tkEndOfStream
Exit Do
End Select

If Token.Suffix <> vbNullChar Then HtmlFile.Access Token.Suffix
Loop
End Sub

Private Function EncodeHtml(ByVal Text)
Text = Replace(Text, "&", "&amp;")
Text = Replace(Text, "<", "&lt;")
Text = Replace(Text, ">", "&gt;")
EncodeHtml = Text
End Function

Call Main()