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

Let's build a transpiler! Part 46

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

The Pandora connection

This time there was no way to avoid it. That dreaded task was assigned to me. Again.
The company I worked for 110 months during the 2000s had an ERP. It had dozens of forms, and one of them had too many controls. It had text boxes, labels, tabs, date pickers, radio buttons, checkboxes, images, group boxes... you name it.
It had so many controls that when trying to add one more, it would raise an error I suppose few out there have already seen: "Reached limit cannot create any more controls for this form." Its limit was 254. For some reason, VB6 counted controls on a form using a byte, and an odd byte at it, with its largest value being an even number.

I had already searched high and low for unused controls to get rid of them. I even shared labels between controls. You know when you have two labels in a row and you can extend the left one to cover the area of the right one, concatenating their texts separated by clever spaces so you can spare one label? Yeah, I suppose not.

Sooo... I needed to add just one more control to it. There was no way nor time to refactor that beast form. There were no controls left to dispose of. There were no more adjacent labels to be merged. I was running out of ideas. I was doomed.

But then, an evil thought slipped into my mind. What if... No way it will work! But maybe, just maybe...
You see, VB6 has a feature that allows you to have a control array. A control array is a UI control - duh! - that is also an array - duh again!
It is handy when you want to have several controls sharing the same event handler. You even receive the control's index in code to identify which one raised the event.

You can see where this is going.

So I CTRL+C'd a text box at random and CTRL+V'd it. VB's IDE prompted me with a glorious "You already have a control named 'txtWhatever'. Do you want to create a control array?" Well, yes, please, for goodness's sake!

And then I had it. Not only that particular form had shared labels doing double duties, now it had shared text boxes bearing the same name, each one with its own index, but with unrelated purposes.

Although I had a Cheshire Cat's grin on my face, I couldn't shake the feeling to have just re-enacted Pandora's action.

Back to business

Last time I said I'd try to fix the remaining issues in that code's version. I'm happy to say I was able to, but I changed our code a lot.
Among several changes, these were the most important ones:
By the way, code is still woefully slow and not enough tested.
I'm listing the project in its whole below again.
Next week, I'll start transpiling it to another programming language.
According to this guy, I'm doomed to fail, though.

Andrej Biasic
2021-08-04

Public Class AEIOU
Option Explicit

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


Public Class AttributeConstruct
Option Explicit

Public Id As Identifier
Public Value As IExpression
End Class


Public Class BinaryExpression
Option Explicit
Implements IExpression

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

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


Public Class CallConstruct
Option Explicit
Implements IStmt
Implements IExpression

Private Arguments_ As KeyedList

Public LHS As IExpression

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

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

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

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


Public Class CaseConstruct
Option Explicit

Private Conditions_ As KeyedList
Private Body_ As KeyedList

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

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

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

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


Public Class CloseConstruct
Option Explicit
Implements IStmt

Private FileNumbers_ As KeyedList

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

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

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


Public Class ConstConstruct
Option Explicit
Implements IStmt

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

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


Public Class ContinueConstruct
Option Explicit
Implements IStmt

Public Enum ContinueWhat
cwDo
cwFor
cwWhile
End Enum

Public What As ContinueWhat

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


Public Class ControlPanel
Option Explicit

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

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

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

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

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

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

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

Idx = Targets_.IndexOf(Key)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


Public Class DataType
Option Explicit

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


Public Class Debug
Option Explicit

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

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


Public Class DebugConstruct
Option Explicit
Implements IStmt

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


Public Class DeclareConstruct
Option Explicit

Private Parms_ As KeyedList

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

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

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


Public Class DefaultValidator
Option Explicit
Option Compare Text
Implements IKLValidator

Public AllowedType As String

Private Function IKLValidator_Validate(ByVal Item As Variant) As Boolean
IKLValidator_Validate = TypeName(Item) = AllowedType
End Function
End Class


Public Class DefType
Option Explicit
Const LAST_INDEX = 25

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

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

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

Index = ToIndex(Letter)

If A_Z_ Then
Set Item = Letters_(0)

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

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

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

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

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

A_Z_ = First = 0 And Last = LAST_INDEX

Set Token = New Token
Token.Kind = tkKeyword

Select Case VariableType
Case vbBoolean
Token.Code = kwBoolean

Case vbByte
Token.Code = kwByte

Case vbInteger
Token.Code = kwInteger

Case vbLong
Token.Code = kwLong

Case vbLongLong
Token.Code = kwLongLong

Case vbLongPtr
Token.Code = kwLongPtr

Case vbCurrency
Token.Code = kwCurrency

Case vbDecimal
Token.Code = cxDecimal

Case vbSingle
Token.Code = kwSingle

Case vbDouble
Token.Code = kwDouble

Case vbDate
Token.Code = kwDate

Case vbString
Token.Code = kwString

Case vbObject
Token.Code = cxObject

Case vbVariant
Token.Code = kwVariant

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

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

Set Letters_(Letter) = Token
Next
End Sub

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

Dim Result As Integer

Debug.Assert Letter <> ""

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


Public Class DimAdder
Option Explicit
Implements IVarAdder

Private Vars_ As KeyedList
Private Panel_ As ControlPanel

Private Sub IVarAdder_Add(ByVal SourcePath As String, ByVal Var As Variable, ByVal Name As String)
Vars_.Add Var, Name
Panel_.AddVar SourcePath, Var
SymTable.Add Var, Panel_, IsStdLib:=Panel_.Entity.StdLib
End Sub

Private Property Set IVarAdder_Panel(ByVal Value As ControlPanel)
Set Panel_ = Value
End Property

Private Property Get IVarAdder_Panel() As ControlPanel
Set IVarAdder_Panel = Panel_
End Property

Private Property Set IVarAdder_Vars(ByVal Value As KeyedList)
Set Vars_ = Value
End Property

Private Property Get IVarAdder_Vars() As KeyedList
Set IVarAdder_Vars = Vars_
End Property
End Class


Public Class DoConstruct
Option Explicit
Implements IStmt

Public Enum DoWhat
dtNone
dtDoLoop
dtDoWhileLoop
dtDoUntilLoop
dtDoLoopWhile
dtDoLoopUntil
End Enum

Private Body_ As KeyedList

Public Condition As IExpression
Public DoType As DoWhat

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

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

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


Public Class EndConstruct
Option Explicit
Implements IStmt

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


Public Class Entity
Option Explicit

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Public Property Get Impls() As KeyedList
Set Impls = Impls_
End Property

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

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

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

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

Public Property Get Properties() As KeyedList
Set Properties = Props_
End Property

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


Public Class EnumConstruct
Option Explicit

Private Enumerands_ As KeyedList

Public Access As Accessibility
Public Id As Identifier

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

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


Public Class EnumerandConstruct
Option Explicit

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


Public Class EraseConstruct
Option Explicit
Implements IStmt

Private Vars_ As KeyedList

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

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

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


Public Class ErrObject
Option Explicit

Public Sub Clear()
End Sub

Public Property Get Description() As String
End Property

Public Property Let Description(ByRef Value As String)
End Property

Public Property Get HelpContext() As Long
End Property

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

Public Property Get HelpFile() As String
End Property

Public Property Let HelpFile(ByRef Value As String)
End Property

Public Property Get LastDllError() As Long
End Property

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

Public Default Property Get Number() As Long
End Property

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

Public Sub Raise( _
ByRef Number As Long, _
Optional ByRef Source As Variant, _
Optional ByRef Description As Variant, _
Optional ByRef HelpFile As Variant, _
Optional ByRef HelpContext As Variant _
)
End Sub

Public Property Get Source() As String
End Property

Public Property Let Source(ByRef Value As String)
End Property
End Class


Public Class EventConstruct
Option Explicit

Private Parms_ As KeyedList

Public Id As Identifier

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

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

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


Public Class ExitConstruct
Option Explicit
Implements IStmt

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

Public What As ExitWhat

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


Public Class ExprChecker
Option Explicit
Implements IVisitor

Private SrcPath_ As String
Private It_ As IVisitor

Private Sub Class_Initialize()
Set It_ = Me


End Sub

Private Sub IVisitor_VisitExpression( _
ByVal Entity As Entity, _
ByVal NullMethod As IMethod, _
ByVal Expr As IExpression, _
ByVal Withs As KeyedList, _
Optional ByVal IsSet As Boolean, _
Optional ByVal IsLHS As Boolean, _
Optional ByVal Op As Operator, _
Optional ByRef Break As Boolean _
)
Dim Code As Long
Dim Flags As Long
Dim Vt As Long
Dim Stage As Integer 'Used to track TYPEOF ? IS ?
Dim Dflt As Integer 'Used to track PROC(?) . ?
Dim Idx As Integer
Dim Item As Variant
Dim Found As PINQ
Dim Sym As Symbol
Dim Row As SymRow
Dim TInfo As SymRow
Dim Lit As Literal
Dim List As KeyedList
Dim Hndl As FileHandle
Dim IExpr As IExpression
Dim Prc As CallConstruct
Dim Bin As BinaryExpression

On Error GoTo ErrHandler
Set List = New KeyedList
Degraph Expr, List

Do
Rem Rationale behind [Dflt]:
Rem It is set to 1 when we detect a procedure call or a subescript expression, i.e., A(B)
Rem It is incremented in further iterations.
Rem When it is 2, then we check whether the TInfo (type info) from the last iteration was marked as being
Rem the default element of a class.
Rem If [Dflt] pasts 2, then our expectation to detect a default being used was not met.
If Dflt Then Dflt = Dflt + 1
If Dflt > 2 Then Dflt = 0

Idx = Idx + 1
Set Item = List(Idx)

If TypeOf Item Is Operator Then
Rem Rationale behind [Stage]:
Rem It is set to 1 when we have a [TypeOf] being used.
Rem It is incremented in further iterations.
Rem When it is 2, we can differentiate [Is] properly, as it can be used by itself.
Rem If [Stage] pasts 2, we simply clear it to 0.
If Stage Then Stage = Stage + 1
If Stage > 2 Then Stage = 0
Set Op = Item

Select Case Op.Value.Code
Case opDot
Debug.Assert Idx > 1
Debug.Assert Idx + 1 <= List.Count

If Dflt = 2 And (TInfo.Flags And 2) = 0 Then
Set Found = SymTable.Find(Name:=0, Entity:=TInfo.Name)
Set Found = Found.Where(Found!Flags, [And], 1) 'Get the default element.

If Found.Count = 0 Then
Set TInfo = SymTable.Find(Name:=kwVariant).ToList(1) 'Bail out.
Else
Debug.Assert Found.Count = 1
Set Row = Found.ToList(1) 'Get the element.
Debug.Assert Row.Indirect
Set TInfo = SymTable(Row.Indirect) 'Get its data type.
End If
End If

Idx = Idx + 1
Set Item = List(Idx) 'Move on to next element in expression.
GoSub ExtractCode

If TInfo.Name = kwVariant Then
Set Found = SymTable.Find(Name:=TInfo.Name)

If Not Sym Is Nothing Then
Sym.RowType = rnLateBind
Sym.Binding = Found.ToList(1).Id
End If
Else
Set Found = SymTable.Find(Name:=Code) 'Get a ton of candidates.
Debug.Assert Not TInfo Is Nothing

Rem Maybe we can find the element in TInfo's entity?
If Found.Count > 1 Then _
If Found.Contains(Found!Entity, [=], TInfo.Name) Then _
Set Found = Found.Where(Found!Entity, [=], TInfo.Name)

Rem Maybe we can find the element as a TInfo's child?
If Found.Count > 1 Then _
If Found.Contains(Found!Parent, [=], TInfo.Id) Then _
Set Found = Found.Where(Found!Parent, [=], TInfo.Id)

Rem As the element is after a dot, it *must* be Public or Friend.
If Found.Count > 1 And Sym.RowType <> rnMe Then _
Set Found = Found.Where(Found!Access, [In], Array(acPublic, acFriend))

Rem Maybe we found some Get/Set/Let property?
If Found.Count > 1 Then
If _
Found.Contains(Found!RowType, [=], rnPropertyGet) And _
Found.Contains(Found!RowType, [In], Array(rnPropertyLet, rnPropertySet)) _
Then
If IsLHS And List.Count = Idx Then
If IsSet Then
Set Found = Found.Where(Found!RowType, [=], rnPropertySet)
Else
Set Found = Found.Where(Found!RowType, [=], rnPropertyLet)
End If
Else
Set Found = Found.Where(Found!RowType, [=], rnPropertyGet)
End If
End If
End If

Rem As the element is after a dot, it cannot be a Parameter.
If Idx > 1 And Found.Count > 1 Then Set Found = Found.Where(Found!RowType, [<>], rnParameter)

Rem Maybe we have a variable with the same name as its data type?
If Found.Count > 1 And _
Found.Contains(Found!RowType, [=], rnClass) And _
Found.Contains(Found!RowType, [=], rnVariable) Then _
Set Found = Found.Where(Found!RowType, [=], rnVariable)

Debug.Assert Found.Count = 1
Set TInfo = Found.ToList(1)

If Dflt = 1 Then
Rem We had something that can be a call or a subscript expression.
Select Case TInfo.RowType
Case rnFunction, rnPropertyGet, rnDeclareFunction
Rem If we know for sure that it was a method call, it cannot accept arguments.
Rem If it does, then we're not dealing with an implicit call.
If TInfo.ArgCount > 0 Then Dflt = 0

Case rnParameter, rnVariable
Rem If we know for sure that it is a parameter or a variable, it must be an array.
If (TInfo.Flags And 2) = 0 Then Dflt = 0
End Select
End If

If Not Sym Is Nothing Then Sym.RowType = TInfo.RowType
GoSub AdjustTInfo
End If

Case opWithDot
Debug.Assert Withs.Count > 0
Rem We have already visited this guy, so let's retrieve it.
Set Item = Withs(Withs.Count)
Rem Calling [ExtractCode] not because we want guy's Code/name,
Rem but for the side effect of Sym being Set'ed.
GoSub ExtractCode
Rem Get its type info.
Set TInfo = SymTable(Sym.Binding)

If Dflt = 1 Then
Set Found = SymTable.Find(Name:=0, Entity:=TInfo.Name)
Set Found = Found.Where(Found!Flags, [And], 1) 'Get the default element.

If Found.Count = 1 Then
Set TInfo = Found.ToList(1)
Set TInfo = SymTable(TInfo.Indirect)
End If
End If

Rem Move to next element.
Idx = Idx + 1
If Idx > List.Count Then Stop
Set Item = List(Idx)

GoSub ExtractCode
Rem Get a ton of candidates.
Set Found = SymTable.Find(Name:=Code)

Rem As this element is after a dot, it cannot be a Parameter, and must be Public or Friend.
If Found.Count > 1 Then Set Found = Found.Where(Found!RowType, [<>], rnParameter, [And], Found!Access, [In], Array(acFriend, acPublic))

Rem Trying to find the right element by parent or entity.
If Found.Count > 1 Then
If Found.Contains(Found!Parent, [=], TInfo.Id) Then
Set Found = Found.Where(Found!Parent, [=], TInfo.Id)

ElseIf Found.Contains(Found!Entity, [=], TInfo.Name) Then
Set Found = Found.Where(Found!Entity, [=], TInfo.Name)
End If
End If

If Found.Count = 1 Then
Set TInfo = Found.ToList(1)
Else
Set TInfo = SymTable.Find(Name:=kwVariant).ToList(1)
End If

Sym.Binding = TInfo.Id
Sym.RowType = TInfo.RowType

Case opBang, opWithBang
Rem TODO: Check if the predecessor is a class with a default method
Idx = Idx + 1
Debug.Assert Idx <= List.Count
If Not TypeOf List(Idx) Is Symbol Then Fail SrcPath_, New Token, "" 'TODO: Complete
Set Sym = List(Idx)
Sym.RowType = rnString
Sym.Binding = SymTable.Find(Name:=kwString).ToList(1).Id

Case opNew
GoSub CheckClass

Case opAddressOf
Idx = Idx + 1
Debug.Assert Idx <= List.Count
Debug.Assert TypeOf List(Idx) Is Symbol
Set Sym = List(Idx)
Code = Sym.Value.Code
Set Row = FindFunCallback(Entity, Code)

If Not Row Is Nothing Then
Sym.RowType = rnFunction
Sym.Binding = Row.Id

Else
Set Row = FindSubCallback(Entity, Code)

If Not Row Is Nothing Then
Sym.RowType = rnSub
Sym.Binding = Row.Id

Else
Fail SrcPath_, New Token, "" 'TODO: Complete
End If
End If

Case opByVal
Idx = Idx + 1
Debug.Assert Idx <= List.Count
If Not TypeOf List(Idx) Is Symbol Or Idx <> List.Count Then Fail SrcPath_, New Token, "" 'TODO: Complete

Case opTypeOf
Debug.Assert Idx + 1 <= List.Count

If Not TypeOf List(Idx + 1) Is Symbol And Not TypeOf List(Idx + 1) Is CallConstruct Then
Fail SrcPath_, New Token, "" 'TODO: Complete
End If

Stage = 1

Case opIs, opIsNot
If Stage = 2 Then
GoSub CheckClass
Else
Debug.Assert Idx + 1 <= List.Count

If TypeOf List(Idx + 1) Is Literal Then
Idx = Idx + 1
Set Lit = List(Idx)
If Lit.Value.Code <> kwNothing Then Fail SrcPath_, New Token, "" 'TODO: Complete

ElseIf Not TypeOf List(Idx + 1) Is Symbol Then
Fail SrcPath_, New Token, "" 'TODO: Complete
End If
End If

Case opNamed
Set Sym = List(Idx - 1)
Sym.RowType = rnNamedArg

Case Else
Set TInfo = Nothing
End Select
Else
Set IExpr = Item

Select Case IExpr.Kind
Case ekSymbol
Set Sym = Item
Code = Sym.Value.Code
GoSub CheckSymbol

Case ekIndexer
Set Prc = Item
Dflt = 1

If Prc.LHS.Kind = ekBinaryExpr Or Prc.LHS.Kind = ekUnaryExpr Then
IVisitor_VisitExpression Entity, NullMethod, Prc.LHS, Withs, IsSet, IsLHS
Else
Set Sym = Prc.LHS
Code = Sym.Value.Code
Set TInfo = FindRowType(IsSet, Entity, NullMethod, IsLHS, Code)

Rem Dirty Hack
If TInfo.Id = 0 Then
Code = NameBank.Ids.IndexOf(NameBank(Sym.Value))

If Code <> 0 Then
Code = NameBank.ToIdIndex(Code)
Set TInfo = FindRowType(IsSet, Entity, NullMethod, IsLHS, Code)
End If
End If

Sym.RowType = TInfo.RowType
Sym.Binding = TInfo.Id

Select Case TInfo.RowType
Case rnVariable, rnParameter, rnPropertyGet, rnFunction, rnDeclareFunction
GoSub AdjustTInfo

Case Else
If Withs.Count > 0 Then
Set Item = Withs(Withs.Count)
Debug.Assert TypeOf Item Is CallConstruct

Set Prc = Item
Set Sym = Prc.LHS
Set Found = SymTable.Find(Name:=Sym.Value.Code, RowType:=Sym.RowType)
Debug.Assert Found.Count = 1

Set Row = Found.ToList(1)
Set TInfo = Row
GoSub AdjustTInfo

Debug.Assert TypeOf List(Idx) Is CallConstruct
Set Prc = List(Idx)
Set Sym = Prc.LHS
Set Found = SymTable.Find(Name:=Sym.Value.Code, Entity:=TInfo.Name)

Debug.Assert Found.Count = 1

With Found.ToList(1)
Sym.RowType = .RowType
Sym.Binding = .Id
End With
Else
Debug.Assert False
End If
End Select
End If

Case ekFileHandle
Set Hndl = List(Idx)

If Not IsNumeric(Right$(Hndl.Value.Text, 1)) Then
Code = NameBank.Ids.IndexOf(Hndl.Value.Text)
Set Sym = New Symbol
GoSub CheckSymbol
End If

Case ekLiteral
Set Lit = Item

If Idx < List.Count And Lit.Value.Code = kwMe Then
Set Found = SymTable.Find(Name:=Entity.Id.Name.Code, RowType:=rnClass)
Set TInfo = Found.ToList(1)
End If

Case ekTuple
Debug.Assert False
End Select
End If
Loop Until Idx = List.Count

Break = True
Exit Sub

CheckSymbol:
Set TInfo = FindRowType(IsSet, Entity, NullMethod, Idx = List.Count And IsLHS, Code)
Sym.RowType = TInfo.RowType
Rem Intentional fall-through

AdjustTInfo:
Select Case TInfo.RowType
Case rnEnumerand
Set TInfo = SymTable.Find(Name:=kwLong).ToList(1)

Case rnImplicit
Rem TODO: Use DefType to narrow down the data type?
Set TInfo = SymTable.Find(Name:=kwVariant).ToList(1)

Case rnPropertySet, rnPropertyLet, rnSub, rnDeclareSub
Rem It should be Void
Set TInfo = Nothing

Case rnConst
Vt = VtToKw(vbLong)
Rem TODO: Get const's actual data type
Set TInfo = SymTable.Find(Name:=Vt).ToList(1)

Case rnModule, rnResult
Rem Nothing to do

Case Else
Debug.Assert TInfo.Indirect
Flags = TInfo.Flags
Set TInfo = SymTable(TInfo.Indirect)
TInfo.Flags = Flags
End Select

If Not TInfo Is Nothing Then Sym.Binding = TInfo.Id
Return

CheckClass:
Idx = Idx + 1
Debug.Assert Idx <= List.Count
If Not TypeOf List(Idx) Is Symbol Then Fail SrcPath_, New Token, "" 'TODO: Complete

Set Sym = List(Idx)
Code = Sym.Value.Code
Set Row = FindClass(Code)

If Not Row Is Nothing Then
Sym.RowType = rnClass
Sym.Binding = Row.Id
Else
Fail SrcPath_, New Token, "" 'TODO: Complete
End If

Return

ExtractCode:
Set IExpr = Item

Select Case IExpr.Kind
Case ekSymbol
Set Sym = Item
Code = Sym.Value.Code

Case ekIndexer
Set Prc = Item

If Prc.LHS.Kind = ekBinaryExpr Then
Set Bin = Prc.LHS
Set Sym = Bin.RHS
Else
Set Sym = Prc.LHS
End If

Code = Sym.Value.Code
Dflt = 1

Case ekLiteral
Set Sym = Nothing
Set Lit = Item
Code = Lit.Value.Code

Case ekTuple
Debug.Assert False

Case Else
Debug.Assert False
End Select

Return

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "VisitExpression"
Stop
Resume
ErrReraise
End Sub

Private Sub IVisitor_VisitAccess(ByVal Access As Accessibility, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitAttributes(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Attrs As KeyedList, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitBody(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Body As KeyedList, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitCall(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As CallConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitClose(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As CloseConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitConst(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Cnt As ConstConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitContinue(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ContinueConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitDataType(ByVal Entity As Entity, ByVal Method As IMethod, ByVal DataType As DataType, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitDebug(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As DebugConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitDeclare(ByVal Entity As Entity, ByVal Dcl As DeclareConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitDim(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As Variable, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitDo(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As DoConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitEnd(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As EndConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitEntity(ByVal Entity As Entity, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitEnum(ByVal Entity As Entity, ByVal Enm As EnumConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitErase(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As EraseConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitEvent(ByVal Entity As Entity, ByVal Evt As EventConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitExit(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ExitConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitFor(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ForConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitForEach(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ForEachConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitGet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GetConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitGoSub(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GoSubConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitGoTo(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GoToConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitId(ByVal Id As Identifier, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitIf(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As IfConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitImplements(ByVal Entity As Entity, ByVal Ipl As ImplementsConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitInput(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As InputConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitLabel(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LabelConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitLet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LetConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitLineNumber(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LineNumberConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitLock(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LockConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitLSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LSetConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitName(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As NameConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitOnComputed(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OnComputedConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitOnError(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OnErrorConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitOpen(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OpenConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitOperator(ByVal Stmt As Operator, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitParams(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Params As KeyedList, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitPrint(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As PrintConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitPut(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As PutConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitRaiseEvent(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As RaiseEventConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitReDim(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ReDimConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitReset(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ResetConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitResume(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ResumeConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitReturn(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ReturnConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitRSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As RSetConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitSeek(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SeekConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitSelect(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SelectConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SetConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitSource(ByVal Source As SourceFile, Optional ByRef Break As Boolean)
SrcPath_ = Source.Path
End Sub

Private Sub IVisitor_VisitStmt(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As IStmt, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitStop(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As StopConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitSubscripts(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Subscripts As KeyedList, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitToken(ByVal Stmt As Token, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitType(ByVal Entity As Entity, ByVal Udt As TypeConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitUnlock(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As UnlockConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitWhile(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WhileConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitWidth(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WidthConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitWith(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WithConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitWrite(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WriteConstruct, Optional ByRef Break As Boolean)
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Sub Degraph(ByVal Expr As IExpression, ByVal List As KeyedList)
Dim Uni As UnaryExpression
Dim Bin As BinaryExpression

On Error GoTo ErrHandler

Select Case Expr.Kind
Case ekUnaryExpr
Set Uni = Expr
List.Add Uni.Operator
Degraph Uni.Value, List


Case ekBinaryExpr
Set Bin = Expr
Rem LHS can be Nothing, i.e. Case Is <= 0
If Not Bin.LHS Is Nothing Then Degraph Bin.LHS, List
List.Add Bin.Operator
Degraph Bin.RHS, List

Case Else
List.Add Expr
End Select

Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "Degraph"
ErrReraise
End Sub

Private Function FindRowType( _
ByVal IsSet As Boolean, _
ByVal Entity As Entity, _
ByVal NullMethod As IMethod, _
ByVal IsLHS As Boolean, _
ByVal Code As Long _
) As SymRow
Dim Row As SymRow

Set Row = FindRetVal(Entity, NullMethod, IsLHS, Code)
If Row Is Nothing Then Set Row = FindParm(Entity, NullMethod, Code)
If Row Is Nothing Then Set Row = FindVar(Entity, NullMethod, Code)
If Row Is Nothing Then Set Row = FindPropGet(Entity, IsLHS, Code)
If Row Is Nothing Then Set Row = FindPropLet(Entity, IsLHS And IsSet, Code)
If Row Is Nothing Then Set Row = FindPropSet(Entity, IsLHS And IsSet, Code)
If Row Is Nothing Then Set Row = FindConst(Entity, NullMethod, IsLHS, Code)
If Row Is Nothing Then Set Row = FindEnumerand(Entity, NullMethod, IsLHS, Code)
If Row Is Nothing Then Set Row = FindFunc(Entity, IsLHS, Code)
If Row Is Nothing Then Set Row = FindDecl(Entity, IsLHS, Code)
If Row Is Nothing Then Set Row = FindModule(Code)
If Row Is Nothing Then Set Row = New SymRow
Set FindRowType = Row
End Function

Private Function FindRetVal( _
ByVal Entity As Entity, _
ByVal NullMethod As IMethod, _
ByVal IsLHS As Boolean, _
ByVal Code As Long _
) As SymRow
Dim Found As PINQ

If NullMethod Is Nothing Then Exit Function
If Not IsLHS Then Exit Function
If Code <> NullMethod.Id.Name.Code Then Exit Function
Set Found = SymTable.Find(Name:=Code, Entity:=Entity.Id.Name.Code)

If Found.Contains(Found!RowType, [=], rnPropertyGet) Then
Set FindRetVal = Found.Where(Found!RowType, [=], rnPropertyGet).OrderBy(Found!Level).ToList(1)

ElseIf Found.Contains(Found!RowType, [=], rnFunction) Then
Set FindRetVal = Found.Where(Found!RowType, [=], rnFunction).OrderBy(Found!Level).ToList(1)
End If

If Not FindRetVal Is Nothing Then FindRetVal.RowType = rnResult
End Function

Private Function FindParm(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Code As Long) As SymRow
Dim Found As PINQ

If NullMethod Is Nothing Then Exit Function

Set Found = SymTable.Find( _
Name:=Code, Entity:=Entity.Id.Name.Code, RowType:=rnParameter, _
Method:=SymTable.MethodID(Entity.Id.Name.Code, NullMethod))

Debug.Assert Found.Count <= 1
If Found.Count = 1 Then Set FindParm = Found.ToList(1)
End Function

Private Function FindVar(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Code As Long) As SymRow
Dim Found As PINQ

If NullMethod Is Nothing Then Exit Function

Set Found = SymTable.Find( _
Name:=Code, Entity:=Entity.Id.Name.Code, RowType:=rnVariable, _
Method:=SymTable.MethodID(Entity.Id.Name.Code, NullMethod))
Rem TODO: Problem: What if a variable is used in a Get Property, but declared in a Let one?
Debug.Assert Found.Count <= 1

If Found.Count = 1 Then
Set FindVar = Found.ToList(1)
Exit Function
End If

Set Found = SymTable.Find(Name:=Code, Entity:=Entity.Id.Name.Code, RowType:=rnVariable). _
Where(Found!Level, [=], slEntity, [And], Found!Parent, [=], 0)
Debug.Assert Found.Count <= 1

If Found.Count = 1 Then
Set FindVar = Found.ToList(1)
Exit Function
End If

Set Found = SymTable.Find(Name:=Code, RowType:=rnVariable).Where(Found!Parent, [=], 0)
FilterClassesFrom Found
Rem During tests, there was more than one hit below because it was not really a variable, but a named argument.
Rem It will be fixed in the next ValidateExpr iteration.
'Debug.Assert Found.Count <= 1
If Found.Count = 1 Then Set FindVar = Found.ToList(1)
End Function

Private Function FindPropGet(ByVal Entity As Entity, ByVal IsLHS As Boolean, ByVal Code As Long) As SymRow
Dim Found As PINQ
Dim Item As SymRow

If IsLHS Then Exit Function
Set Found = SymTable.Find(Name:=Code, Entity:=Entity.Id.Name.Code, RowType:=rnPropertyGet)
Debug.Assert Found.Count <= 1

If Found.Count = 1 Then
Set FindPropGet = Found.ToList(1)
Exit Function
End If

Set Found = SymTable.Find(Name:=Code, RowType:=rnPropertyGet, Access:=acPublic)
FilterClassesFrom Found
Debug.Assert Found.Count <= 1
If Found.Count = 1 Then Set FindPropGet = Found.ToList(1)
End Function

Private Function FindPropLet(ByVal Entity As Entity, ByVal IsSet As Boolean, ByVal Code As Long) As SymRow
Dim Found As PINQ
Dim Item As SymRow

If IsSet Then Exit Function
Set Found = SymTable.Find(Name:=Code, Entity:=Entity.Id.Name.Code, RowType:=rnPropertyLet)
Debug.Assert Found.Count <= 1

If Found.Count = 1 Then
Set FindPropLet = Found.ToList(1)
Exit Function
End If

Set Found = SymTable.Find(Name:=Code, RowType:=rnPropertyLet, Access:=acPublic)
FilterClassesFrom Found
Debug.Assert Found.Count <= 1
If Found.Count = 1 Then Set FindPropLet = Found.ToList(1)
End Function

Private Function FindPropSet(ByVal Entity As Entity, ByVal IsSet As Boolean, ByVal Code As Long) As SymRow
Dim Found As PINQ
Dim Item As SymRow

If Not IsSet Then Exit Function
Set Found = SymTable.Find(Name:=Code, Entity:=Entity.Id.Name.Code, RowType:=rnPropertySet)
Debug.Assert Found.Count <= 1

If Found.Count = 1 Then
Set FindPropSet = Found.ToList(1)
Exit Function
End If

Set Found = SymTable.Find(Name:=Code, RowType:=rnPropertySet, Access:=acPublic)
FilterClassesFrom Found
Debug.Assert Found.Count <= 1
If Found.Count = 1 Then Set FindPropSet = Found.ToList(1)
End Function

Private Function FindConst( _
ByVal Entity As Entity, _
ByVal NullMethod As IMethod, _
ByVal IsLHS As Boolean, _
ByVal Code As Long _
) As SymRow
Dim Found As PINQ

If IsLHS Then Exit Function

If Not NullMethod Is Nothing Then
Set Found = SymTable.Find( _
Name:=Code, Entity:=Entity.Id.Name.Code, RowType:=rnConst, _
Method:=SymTable.MethodID(Entity.Id.Name.Code, NullMethod))
Debug.Assert Found.Count <= 1

If Found.Count = 1 Then
Set FindConst = Found.ToList(1)
Exit Function
End If
End If

Set Found = SymTable.Find(Name:=Code, Entity:=Entity.Id.Name.Code, RowType:=rnConst)
Set Found = Found.Where(Found!Method, [=], 0)
Debug.Assert Found.Count <= 1

If Found.Count = 1 Then
Set FindConst = Found.ToList(1)
Exit Function
End If

Set Found = SymTable.Find(Name:=Code, RowType:=rnConst)
FilterClassesFrom Found
Debug.Assert Found.Count <= 1
If Found.Count = 1 Then Set FindConst = Found.ToList(1)
End Function

Private Function FindEnumerand( _
ByVal Entity As Entity, _
ByVal NullMethod As IMethod, _
ByVal IsLHS As Boolean, _
ByVal Code As Long _
) As SymRow
Dim Found As PINQ

If IsLHS Then Exit Function

Set Found = SymTable.Find(Name:=Code, Entity:=Entity.Id.Name.Code, RowType:=rnEnumerand)
Debug.Assert Found.Count <= 1

If Found.Count = 1 Then
Set FindEnumerand = Found.ToList(1)
Exit Function
End If

Set Found = SymTable.Find(Name:=Code, RowType:=rnEnumerand, Access:=acPublic)
Debug.Assert Found.Count <= 1
If Found.Count = 1 Then Set FindEnumerand = Found.ToList(1)
End Function

Private Function FindFunc(ByVal Entity As Entity, ByVal IsLHS As Boolean, ByVal Code As Long) As SymRow
Dim Found As PINQ

If IsLHS And _
Code <> NameBank.ToIdIndex(NameBank.Ids.IndexOf(v.Mid)) And _
Code <> NameBank.ToIdIndex(NameBank.Ids.IndexOf(v.MidB)) _
Then Exit Function

Set Found = SymTable.Find(Name:=Code, Entity:=Entity.Id.Name.Code, RowType:=rnFunction)
Debug.Assert Found.Count <= 1

If Found.Count = 1 Then
Set FindFunc = Found.ToList(1)
Exit Function
End If

Set Found = SymTable.Find(Name:=Code, RowType:=rnFunction, Access:=acPublic)
FilterClassesFrom Found
Debug.Assert Found.Count <= 1
If Found.Count = 1 Then Set FindFunc = Found.ToList(1)
End Function

Private Function FindDecl(ByVal Entity As Entity, ByVal IsLHS As Boolean, ByVal Code As Long) As SymRow
Dim Found As PINQ

If IsLHS Then Exit Function

Set Found = SymTable.Find(Name:=Code, Entity:=Entity.Id.Name.Code, RowType:=rnDeclareFunction)
Debug.Assert Found.Count <= 1

If Found.Count = 1 Then
Set FindDecl = Found.ToList(1)
Exit Function
End If

Set Found = SymTable.Find(Name:=Code, RowType:=rnDeclareFunction, Access:=acPublic)
FilterClassesFrom Found
Debug.Assert Found.Count <= 1
If Found.Count = 1 Then Set FindDecl = Found.ToList(1)
End Function

Private Sub FilterClassesFrom(ByVal Entities As PINQ)
Dim Idx As Long
Dim Found As PINQ
Dim KL As KeyedList

Set KL = Entities

For Idx = KL.Count To 1 Step -1
Set Found = SymTable.Find(Name:=Entities.ToList(Idx).Entity, RowType:=rnModule)
If Found.Count = 0 Then KL.Remove Idx
Next
End Sub

Private Function FindClass(ByVal Code As Long) As SymRow
Dim Result As PINQ

Set Result = SymTable.Find(Name:=Code, RowType:=rnClass)
If Result.Count = 1 Then Set FindClass = Result.ToList(1)
End Function

Private Function FindFunCallback(ByVal Entity As Entity, ByVal Code As Long) As SymRow
Dim Found As PINQ

Set Found = SymTable.Find(Name:=Code)
Set Found = Found.Where(Found!RowType, [=], rnFunction). _
Where(Found!Access, [=], acPublic, [Or], Found!Entity, [=], Entity.Id.Name.Code)
FilterClassesFrom Found
If Found.Count = 1 Then Set FindFunCallback = Found.ToList(1)
End Function

Private Function FindSubCallback(ByVal Entity As Entity, ByVal Code As Long) As SymRow
Dim Found As PINQ

Set Found = SymTable.Find(Name:=Code)
Set Found = Found.Where(Found!RowType, [=], rnSub). _
Where(Found!Access, [=], acPublic, [Or], Found!Entity, [=], Entity.Id.Name.Code)
FilterClassesFrom Found
If Found.Count = 1 Then Set FindSubCallback = Found.ToList(1)
End Function

Private Function FindEnum(ByVal Entity As Entity, ByVal Code As Long) As SymRow
Dim Found As PINQ

Set Found = SymTable.Find(Name:=Code, Entity:=Entity.Id.Name.Code, RowType:=rnEnum)
Debug.Assert Found.Count <= 1

If Found.Count = 1 Then
Set FindEnum = Found.ToList(1)
Exit Function
End If

Set Found = SymTable.Find(Name:=Code, RowType:=rnEnum)
Set Found = Found.Where(Found!Access, [In], Array(acPublic, acFriend))

Debug.Assert Found.Count <= 1
If Found.Count = 1 Then Set FindEnum = Found.ToList(1)
End Function

Private Function FindModule(ByVal Code As Long) As SymRow
Dim Found As PINQ

Set Found = SymTable.Find(Name:=Code, RowType:=rnModule)
Debug.Assert Found.Count <= 1
If Found.Count = 1 Then Set FindModule = Found.ToList(1)
End Function
End Class


Public Class Expressionist
Option Explicit

Private LastToken_ As Token

Public CanHaveTo As Boolean
Public FullMode As Boolean

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

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

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

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

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

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

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

WantOperand = True

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

If WantOperand Then
WantOperand = False

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

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

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

Case opSubt
Token.Code = opNeg

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

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

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

Case opDot
Token.Code = opWithDot

Case opBang
Token.Code = opWithBang

Case Else
Exit Do
End Select

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

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

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

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

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

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

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

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

Case Else
GoSub CheckDowngrade
If Token.Kind = tkKeyword Then Exit Do
End Select

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

Exit Do
End If

Select Case Token.Kind
Case tkOperator
Down:
Count = Count + IIf(Count < 0, -1, 1)

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

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

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

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

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

Set Op = NewOperator(Token)

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

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

OpStack.Add Op
WantOperand = True

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

Move OpStack, OutStack, Op
Loop

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

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

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

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

Case tkLeftParenthesis
If Not FullMode Then Exit Do

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

Set Args = New TupleConstruct
Set Token = CollectArgs(Args.Elements, Parser)
If Token.Kind <> tkRightParenthesis Then Fail Parser.SourceFile.Path, Token, m.ParensMismatch
OutStack.Add Args

Case Else
Exit Do
End Select
End If

Set Token = Nothing
Loop

Set LastToken_ = Token

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

Move OpStack, OutStack, Op
Loop

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

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

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

Private Sub Move(ByVal OpStack As KeyedList, ByVal OutStack As KeyedList, Optional ByVal Op As Operator)
Dim Elem As Variant
Dim Token As Token
Dim Lit As Literal
Dim IExpr As IExpression
Dim Exec As CallConstruct
Dim Tup As TupleConstruct
Dim Uni As UnaryExpression
Dim Bin As BinaryExpression

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

If Op.IsUnary Then
Set Uni = New UnaryExpression
Set Uni.Operator = Op
Set Uni.Value = Pop(OutStack)
Set IExpr = Uni
'----------------------------------------------------------------------------------------------------
If Uni.Operator.Value.Code = opNeg And Uni.Value.Kind = ekLiteral Then
Set Lit = Uni.Value

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

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

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

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

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

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

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

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

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

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

Else
Set Bin = New BinaryExpression
Set Bin.Operator = Op
Set Bin.RHS = Pop(OutStack)
Set Bin.LHS = Pop(OutStack)
Set IExpr = Bin
End If

OutStack.Add IExpr
Pop OpStack
End Sub

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

Set Xp = New Expressionist
If Token Is Nothing Then Set Token = Parser.NextToken

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

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

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

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

Do
Done = True

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

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

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

Set Token = Parser.NextToken

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

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

Set Name = Bin

Set Token = Parser.NextToken
Done = False

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

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

Set Result = Asg

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

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

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

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

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

Set Result = Asg
End Select

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

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

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

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

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

Case Else
Exit Do
End Select

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

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

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

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

Set Result = Exec
End Select
Loop Until Done

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

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

Set Xp = New Expressionist
Xp.FullMode = True

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

Set Lit = New Literal
Set Lit.Value = Token

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

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

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

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

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

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

Args.Add Expr

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

Set CollectArgs = Token
End Function
End Class


Public Class ExprValidator
Option Explicit
Implements IKLValidator

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


Public Class Field
Option Explicit

Public Default Name As String
End Class


Public Class FileHandle
Option Explicit
Implements IExpression
Implements IBindable

Public Binding As Long
Public Value As Token

Private Property Let IBindable_Binding(ByVal NewValue As Long)
Binding = NewValue
End Property

Private Property Get IBindable_Binding() As Long
IBindable_Binding = Binding
End Property

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


Public Class FileTextBuilder
Option Explicit
Implements ITextBuilder

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

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

Private Sub Class_Terminate()
Close Handle_
End Sub

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

IsNewLine_ = False
Print #Handle_, Text;
End Sub

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

IsNewLine_ = True
End Sub

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

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


Public Class ForConstruct
Option Explicit
Implements IStmt

Private Body_ As KeyedList

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

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

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

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


Public Class ForEachConstruct
Option Explicit
Implements IStmt

Private Body_ As KeyedList

Public Element As Symbol
Public Group As IExpression

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

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

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


Public Class FunctionConstruct
Option Explicit
Implements IMethod

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

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

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

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

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

Set Consts_ = New KeyedList
Set Consts_.T = NewValidator(TypeName(New ConstConstruct))
End Sub

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

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

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

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

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

Private Property Get IMethod_Consts() As KeyedList
Set IMethod_Consts = Consts_
End Property

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

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

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

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


Public Class GetConstruct
Option Explicit
Implements IStmt

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

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


Public Class GoSubConstruct
Option Explicit
Implements IStmt

Public Target As IStmt

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


Public Class GoToConstruct
Option Explicit
Implements IStmt

Public Target As IStmt

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


Public Class IBindable
Option Explicit

Public Binding As Long

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


Public Class Identifier
Option Explicit

Private Name_ As Token
Private Project_ As Token

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

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

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


Public Class IEnumVARIANT
Option Explicit

Public Sub Clone(ByRef ppEnum As IEnumVARIANT)
End Sub

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

Public Sub Reset()
End Sub

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


Public Class IExpression
Option Explicit

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

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

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


Public Class IfArm
Option Explicit

Private Body_ As KeyedList

Public Condition As IExpression

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

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


Public Class IfConstruct
Option Explicit
Implements IStmt

Private Arms_ As KeyedList
Private ElseBody_ As KeyedList

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

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

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

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

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


Public Class IKLValidator
Option Explicit

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

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


Public Class IMethod
Option Explicit

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

Public Property Get Kind() As VbCallType
End Property

Public Property Get Access() As Accessibility
End Property

Public Property Get Id() As Identifier
End Property

Public Property Get DataType() As DataType
End Property

Public Property Get Parameters() As KeyedList
End Property

Public Property Get Consts() As KeyedList
End Property
End Class


Public Class ImplementsConstruct
Option Explicit

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


Public Class InputConstruct
Option Explicit
Implements IStmt

Private Vars_ As KeyedList

Public FileNumber As IExpression

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

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

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


Public Class IPictureDisp
Option Explicit

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

Public Sub Render( _
ByRef hdc As Long, _
ByRef x As Long, _
ByRef y As Long, _
ByRef cx As Long, _
ByRef cy As Long, _
ByRef xSrc As Long `OLE_XPOS_HIMETRIC´, _
ByRef ySrc As Long `OLE_YPOS_HIMETRIC´, _
ByRef cxSrc As Long `OLE_XSIZE_HIMETRIC´, _
ByRef cySrc As Long `OLE_YSIZE_HIMETRIC´, _
ByRef prcWBounds As `Any´ Variant _
)
End Sub
End Class


Public Class IStmt
Option Explicit

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

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

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


Public Class ITextBuilder
Option Explicit

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

Public Sub Append(ByVal Text As String)
End Sub

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

Public Sub Indent()
End Sub

Public Sub Deindent()
End Sub
End Class


Public Class IUnknown
Option Explicit

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

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

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


Public Class IVarAdder
Option Explicit

Public Vars As KeyedList
Public Panel As ControlPanel

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

Public Sub Add(ByVal SourcePath As String, ByVal Var As Variable, ByVal Name As String)
End Sub
End Class


Public Class IVisitor
Option Explicit

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

Public Sub VisitSource(ByVal Source As SourceFile, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitEntity(ByVal Entity As Entity, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitAttributes(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Attrs As KeyedList, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitAccess(ByVal Access As Accessibility, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitImplements(ByVal Entity As Entity, ByVal Ipl As ImplementsConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitEvent(ByVal Entity As Entity, ByVal Evt As EventConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitId(ByVal Id As Identifier, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitParams(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Params As KeyedList, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitDataType(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal DataType As DataType, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitType(ByVal Entity As Entity, ByVal Udt As TypeConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitSubscripts(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Subscripts As KeyedList, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitConst(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Cnt As ConstConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitDeclare(ByVal Entity As Entity, ByVal Dcl As DeclareConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitEnum(ByVal Entity As Entity, ByVal Enm As EnumConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitExpression( _
ByVal Entity As Entity, _
ByVal NullMethod As IMethod, _
ByVal Expr As IExpression, _
ByVal Withs As KeyedList, _
Optional ByVal IsSet As Boolean, _
Optional ByVal IsLHS As Boolean, _
Optional ByVal PrevOp As Operator, _
Optional ByRef Break As Boolean _
)
End Sub

Public Sub VisitBody(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Body As KeyedList, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitStmt(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As IStmt, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitCall(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As CallConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitClose(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As CloseConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitContinue(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ContinueConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitDebug(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As DebugConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitDim(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Stmt As Variable, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitDo(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As DoConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitEnd(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As EndConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitErase(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As EraseConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitExit(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ExitConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitFor(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ForConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitForEach(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ForEachConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitGet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GetConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitGoSub(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GoSubConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitGoTo(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GoToConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitIf(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As IfConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitInput(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As InputConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitLabel(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LabelConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitLet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LetConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitLineNumber(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LineNumberConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitLock(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LockConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitLSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LSetConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitName(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As NameConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitOnError(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OnErrorConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitOnComputed(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OnComputedConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitOpen(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OpenConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitPrint(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As PrintConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitPut(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As PutConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitRaiseEvent(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As RaiseEventConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitReDim(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ReDimConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitReset(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ResetConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitResume(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ResumeConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitReturn(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ReturnConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitRSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As RSetConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitSeek(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SeekConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitSelect(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SelectConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SetConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitStop(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As StopConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitUnlock(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As UnlockConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitWhile(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WhileConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitWidth(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WidthConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitWith(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WithConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitWrite(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WriteConstruct, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitToken(ByVal Stmt As Token, Optional ByRef Break As Boolean)
End Sub

Public Sub VisitOperator(ByVal Stmt As Operator, Optional ByRef Break As Boolean)
End Sub
End Class


Public Class KeyedList
Option Explicit

Private ReadOnly_ As Boolean
Private Base_ As Integer
Private Id_ As Long
Private Count_ As Long
Private Root_ As KLNode
Private Last_ As KLNode
Private Validator_ As IKLValidator
Private CompareMode_ As VbCompareMethod

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

Private Sub Class_Terminate()
ReadOnly_ = False
Clear
End Sub

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

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

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

If ReadOnly_ Then Err.Raise 5, "KeyedList.Add"
If Not Validator_ Is Nothing Then If Not Validator_.Validate(Item) Then Err.Raise 13

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

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

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

Case Else
Err.Raise 13
End Select

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

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

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

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

If Index < Base_ Then Index = Base_

If Index <> Count_ Then
Set Curr = Root_

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

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

Exit Sub
End If
End If

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

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

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

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

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

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

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

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

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

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

If ReadOnly_ Then Err.Raise 5, "KeyedList.Remove"
Set CurNode = Root_

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

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

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

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

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

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

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

If Found Then Count_ = Count_ - 1 Else Err.Raise 5, "KeyedList.Remove"
End Sub

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

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

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

If ReadOnly_ Then Err.Raise 5, "KeyedList.Clear"
Set CurrNode = Root_
Set Root_ = Nothing

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

Count_ = 0
End Sub

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

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

If Idx >= 0 Then
Set Node = Root_

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

Set FindNode = Node
End Function

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

Set Node = Root_

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

Set Node = Node.NextNode
Loop
End Function

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

Set Node = Root_

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

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

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

For Each Value In Values
Add Value
Next
End Sub

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

Udx = UBound(KeyValuePairs)
If Udx Mod 2 = 0 Then Err.Raise 5, "KeyedList.AddKVPairs"

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

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

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

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


Public Class KLEnumerator
Option Explicit

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

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

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

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

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

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

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

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


Public Class KLNode
Option Explicit

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


Public Class LabelConstruct
Option Explicit
Implements IStmt

Public Id As Identifier

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


Public Class LetConstruct
Option Explicit
Implements IStmt

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

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


Public Class LineNumberConstruct
Option Explicit
Implements IStmt

Public Value As Token

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


Public Class Literal
Option Explicit
Implements IExpression

Public Value As Token

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


Public Class LockConstruct
Option Explicit
Implements IStmt

Public FileNumber As IExpression
Public RecordRange As IExpression

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


Public Class LSetConstruct
Option Explicit
Implements IStmt

Public Name As IExpression
Public Value As IExpression

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


Public Class Messages
Option Explicit

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Public Property Get ConstExprReq() As String
ConstExprReq = "Constant expression required"
End Property

Public Property Get WrongNumArg() As String
WrongNumArg = "Wrong number of arguments"
End Property

Public Property Get ExpEvtName() As String
ExpEvtName = "Expected: Event name"
End Property

Public Property Get UnexpInit() As String
UnexpInit = "Unexpected init value"
End Property

Public Property Get WrongDirective() As String
WrongDirective = "An #ElseIf, #Else, or #EndIf must be preceded by an #If clause"
End Property

Public Property Get ExpDirective() As String
ExpDirective = "Expected: #ElseIf, #Else, or #EndIf"
End Property

Public Property Get EndDirective() As String
EndDirective = "You must terminate the #If block with an #EndIf"
End Property

Public Property Get RuleDirectiveIf() As String
RuleDirectiveIf = "Rule: #If condition Then"
End Property
End Class


Public Class NameBank
Option Explicit

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

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

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

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

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

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

Keywords_.ReadOnly = True

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

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

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

Contextuals_.ReadOnly = True

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

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

Operators_.ReadOnly = True

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

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

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

DollarNames_.ReadOnly = True
End Sub

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

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

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

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

Public Property Get DollarNames() As KeyedList
Set DollarNames = DollarNames_
End Property

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

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

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

Public Function ToIdIndex(ByVal Index As Long) As Long
ToIdIndex = Index + Keywords_.Count + Contextuals_.Count
End Function

Public Function FromIdIndex(ByVal Index As Long) As Long
FromIdIndex = Index - Keywords_.Count - Contextuals_.Count
End Function

Public Function ToCtxIndex(ByVal Index As Long) As Long
ToCtxIndex = Index + Keywords_.Count
End Function

Public Function FromCtxIndex(ByVal Index As Long) As Long
FromCtxIndex = Index - Keywords_.Count
End Function
End Class


Public Class NameConstruct
Option Explicit
Implements IStmt

Public OldPathName As IExpression
Public NewPathName As IExpression

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


Public Class OnComputedConstruct
Option Explicit
Implements IStmt

Private Targets_ As KeyedList

Public Value As IExpression
Public IsGoTo As Boolean

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

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

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


Public Class OnErrorConstruct
Option Explicit
Implements IStmt

Public Statement As IStmt

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


Public Class OpenConstruct
Option Explicit
Implements IStmt

Public Enum FileModes
fmRandom
fmAppend
fmBinary
fmInput
fmOutput
End Enum

Public Enum FileAccesses
faNone
faRead
faWrite
faReadWrite
End Enum

Public Enum FileLocks
flShared
flRead
flWrite
flReadWrite
End Enum

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

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


Public Class Operator
Option Explicit

Public Value As Token

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

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


Public Class Parameter
Option Explicit

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


Public Class Parser
Option Explicit

Public Enum Accessibility
acLocal
acPublic
acPrivate
acFriend
End Enum

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

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

Private Type AccessToken
Access As Accessibility
Token As Token
IsDefault As Boolean
End Type

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

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

Public Property Set SourceFile(ByVal Source As SourceFile)
Set Scanner_ = New Scanner
Set Source_ = Source
Scanner_.OpenFile Source_.Path

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

Public Property Get SourceFile() As SourceFile
Set SourceFile = Source_
End Property

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

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

Do
Done = True

If LookAhead_ Is Nothing Then
Set Token = Scanner_.GetToken(ReturnInlineComment:=ForPrint)
Else
Set Token = LookAhead_
Set LookAhead_ = Nothing
End If

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

If Downgrade_ And Not LastToken_ Is Nothing Then _
If LastToken_.Kind = tkIdentifier And _
LastToken_.Code < NameBank.ToIdIndex(0) Then _
EnsureIdExists LastToken_

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

Case tkKeyword
If Downgrade_ Then
Downgrade_ = False
EnsureIdExists Token

Else
Select Case Token.Code
Case kwAs
WasAs_ = True

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

Case kwDate, kwString
If Not WasAs_ Then EnsureIdExists Token

Case kwDeclare
If State_ = ncNone Then State_ = ncDeclare

Case kwFor
If State_ = ncNone Then
State_ = ncForNext

ElseIf State_ = ncOpen01 Then
State_ = ncOpen02
End If

Case kwInput
If State_ = ncOpen02 Then State_ = ncOpen03

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

Case kwOpen
If State_ = ncNone Then State_ = ncOpen01

Case kwOption
If State_ = ncNone Then State_ = ncOption

Case kwOn
If State_ = ncNone Then State_ = ncOn

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

Case kwTo
If State_ = ncForNext Then State_ = ncForTo

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

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

Case tkIdentifier
If Downgrade_ And Token.Code <= NameBank.ToIdIndex(0) Then EnsureIdExists Token
Downgrade_ = False
WasAs_ = False

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

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

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

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

Case Else
Upgrade = True
End Select

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

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

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

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

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

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

Case ncDeclare
Upgrade = Token.Code = cxPtrSafe

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

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

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

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

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

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

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

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

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

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

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

Case tkFileHandle
If State_ = ncOpen10 Then State_ = ncOpen11

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

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

Case tkWhiteSpace
Done = False
Spaces = Spaces + 1

Case tkSoftLineBreak, tkHardLineBreak
WasAs_ = False
End Select

If Upgrade Then
If Token.Suffix <> vbNullChar Then Fail Token, m.NoSygil

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

Select Case Token.Kind
Case tkWhiteSpace, tkInlineComment
Rem OK

Case Else
Set LastToken_ = Token
End Select
Loop Until Done

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

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

On Error GoTo ErrHandler
Set SourceFile = Source

Do
Set Entity = New Entity

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

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

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

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

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

ElseIf Entity.Access = acLocal Then
Fail Token, m.RuleEntityHeader, m.PublicEtc

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

Set Mark = Token

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

Set Entity.Id = NewId(Token)

If Entity.IsClass Then
Select Case UCase$(NameBank(Entity.Id.Name))
Case "ERROBJECT", "IENUMVARIANT", "IPICTUREDISP", "IUNKNOWN", "DEBUG"
Entity.StdLib = True
End Select
Else
Select Case UCase$(NameBank(Entity.Id.Name))
Case "CONSTANTS", "CONVERSION", "DATETIME", "FILESYSTEM", "FINANCIAL", "GLOBAL", _
"INFORMATION", "INTERACTION", "MATH", "STDOLE", "STRINGS"
Entity.StdLib = True
End Select
End If

SymTable.Add Entity, IsStdLib:=Entity.StdLib
MustEatLineBreak

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

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

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

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

Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "Parse"
ErrReraise
End Sub

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

On Error GoTo ErrHandler
Set Panel = New ControlPanel
Set Panel.Entity = Entity

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

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

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

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

Set Token = NextToken

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

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

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

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

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

Case cxText
Entity.OptionCompare = vbTextCompare

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Case Else
Fail Token, m.ExpOptEtc
End Select

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

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

ElseIf Token.Kind = tkDirective Then
ParseDirective Token

Else
Fail Token, m.ExpOptEtc
End If
Loop

With ParseDeclarationArea
.Access = Access
Set .Token = Token
.IsDefault = HadDefault
End With

Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseDeclarationArea"
ErrReraise
End Function

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

On Error GoTo ErrHandler
IsDefault = AccessToken.IsDefault
HadDefault = IsDefault

Access = AccessToken.Access
Set Token = AccessToken.Token

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

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

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

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

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

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

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

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

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

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

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

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

Case Else
Exit Do
End Select

Set Token = SkipLineBreaks
If Token.IsId(cxProperty) Then Token.Kind = tkKeyword
Loop

Set ParseProcedureArea = Token
Exit Function

Cleanup:
IsStatic = False
IsDefault = False
IsIterator = False
Access = acLocal
Return

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseProcedureArea"
ErrReraise
End Function

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

On Error GoTo ErrHandler

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

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

First = NameBank(Token)
Set Token = NextToken

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

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

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

If Err Then
On Error GoTo 0
Fail Token, m.DuplDefType
End If

On Error GoTo 0

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

Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseDef"
ErrReraise
End Sub

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

On Error GoTo ErrHandler

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

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

Set Token = NextToken

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

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

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

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

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

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

Rem Discard "="
If Not Token.IsOperator(opEq) Then Fail Token, m.RuleConst, m.Equal

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

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

Rem Save it
Body.AddKeyValue NameBank(Cnt.Id.Name), Cnt
If Not Panel.Method Is Nothing Then Panel.Method.Consts.Add Cnt
Panel.AddConst Source_.Path, Cnt
SymTable.Add Cnt, Panel, IsStdLib:=Panel.Entity.StdLib

Rem Move on
Set Token = Xp.LastToken

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

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

Set ParseConsts = Token
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseConsts"
ErrReraise
End Function

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

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

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

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

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

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

Set Token = NextToken

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

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

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

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

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

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

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

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseEnum"
ErrReraise
End Sub

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

On Error GoTo ErrHandler
Set Dcl = New DeclareConstruct
If Access = acLocal Then Access = acPublic
Dcl.Access = Access

Rem Is it PtrSafe?
Set Token = NextToken

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

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

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

Else
Rem It is not a Sub nor a Function
Fail Token, m.RuleDeclareHeader, m.SubFunc
End If

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

Set Dcl.Id = NewId(Token)

Rem Maybe there is a CDecl?
Set Token = NextToken

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

Rem Discard Lib
If Not Token.IsKeyword(cxLib) Then Fail Token, m.RuleDeclareHeader, v.Lib

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

Rem Maybe there is an Alias?
Set Token = NextToken

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

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

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

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

Rem Get data type name
Set Token = NextToken

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

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

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

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

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

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

Set Token = NextToken
End If
End If

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

Set Dcl.DataType = NewDataType(Tkn)

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

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

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

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

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseDeclare"
ErrReraise
End Sub

Private Function ParseParms( _
ByVal Panel As ControlPanel, _
ByVal SignatureKind As SignatureKind, _
ByVal Parms As KeyedList _
) As Token
Dim IsArray As Boolean
Dim Count As Integer
Dim Index As Integer
Dim Name As String
Dim Token As Token
Dim LastParm As Parameter
Dim CurrParm As Parameter
Dim Xp As New Expressionist

On Error GoTo ErrHandler
Set LastParm = New Parameter
Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = NextToken

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

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

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

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

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

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

Set Token = NextToken

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

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

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

If SignatureKind = skDeclare Then
If Not IsDataType(Token) Then Fail Token, m.RuleParm, m.DataType
Else
If Not IsProperDataType(Token) Then Fail Token, m.RuleParm, m.DataType
End If

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

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

Set CurrParm.DataType.Id.Name = Token

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

Set Token = NextToken
End If

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

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

CurrParm.DataType.IsArray = IsArray

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

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

GoSub AddParm
Set Token = NextToken
Exit Do
End If

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

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

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

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

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

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

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

Parms.AddKeyValue Name, CurrParm
If SignatureKind <> skDeclare And SignatureKind <> skEvent Then Panel.AddVar Source_.Path, CurrParm
Return

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseParms"
ErrReraise
End Function

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

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

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

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

If Not IsBreak(Token) Then Fail Token, m.ExpEOS
CheckDupl Panel.Entity, Evt.Id.Name
Panel.Entity.Events.AddKeyValue NameBank(Evt.Id.Name), Evt
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseEvent"
ErrReraise
End Sub

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

On Error GoTo ErrHandler
Set Token = SkipLineBreaks
EnsureIdExists Token
If Token.Kind <> tkIdentifier Then Fail Token, m.RuleImplements, m.PrjOrId
If Token.Suffix <> vbNullChar Then Fail Token, m.NoSygil

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

Set Token = NextToken

If Token.IsOperator(opDot) Then
Set Token = NextToken
If Token.Kind <> tkIdentifier Then Fail Token, m.RuleImplements, m.IdName
If Token.Suffix <> vbNullChar Then Fail Token, m.NoSygil

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

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

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseImplements"
ErrReraise
End Sub

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

On Error GoTo ErrHandler
If Access = acLocal Then Access = acPublic
Set Proc = New SubConstruct
Proc.Access = Access
Proc.IsDefault = HadDefault

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

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

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

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

Set Token = ParseAttributes(Proc.Attributes)
Set Panel.Method = Nothing
SymTable.Add Proc, Panel, IsStdLib:=Panel.Entity.StdLib
Set Panel.Method = Proc

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

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

Set ParseSub = Proc
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseSub"
ErrReraise
End Function

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

On Error GoTo ErrHandler
If Access = acLocal Then Access = acPublic
Set Func = New FunctionConstruct
Func.Access = Access
Func.IsDefault = HadDefault

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

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

Set Token = NextToken

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

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

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

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

Set Token = NextToken

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

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

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

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

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

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

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

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

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

Set ParseFunction = Func
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseFunction"
ErrReraise
End Function

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

On Error GoTo ErrHandler
If Access = acLocal Then Access = acPublic
Set Prop = New PropertyConstruct
Prop.Access = Access
Prop.IsDefault = HadDefault

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

Select Case Token.Code
Case kwGet
Kind = VbGet

Case kwLet
Kind = VbLet

Case kwSet
Kind = VbSet

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

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

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

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

CheckDupl Panel.Entity, Token, JumpProp:=True

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

If Token.Suffix <> vbNullChar And Slot.Id.Name.Suffix <> Token.Suffix Then
Slot.Id.Name.Suffix = Token.Suffix
IsNew = True
Set Slot = New PropertySlot
Set Slot.Id = NewId(Token)
End If
Else
IsNew = True
Set Slot = New PropertySlot
Set Slot.Id = NewId(Token)
End If

Set Token = NextToken

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

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

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

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

Set Token = NextToken

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

If Prop.DataType.Id.Name.Code <> RightParms(RightParms.Count).DataType.Id.Name.Code Then _
Fail Slot.Id.Name, m.PropMismatch
End If
End If

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

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

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

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

Set ParseProperty = Prop
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseProperty"
ErrReraise
End Function

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

On Error GoTo ErrHandler

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

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

Set Token = NextToken

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

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

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

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

Set ParseAttributes = Token
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseAttributes"
ErrReraise
End Function

Private Sub ParseDim( _
ByVal Access As Accessibility, _
ByVal Panel As ControlPanel, _
ByVal Vars As KeyedList, _
Optional ByVal InsideProc As Boolean, _
Optional ByVal IsStatic As Boolean, _
Optional ByVal Token As Token, _
Optional HasDefault As Boolean _
)
Dim Adder As IVarAdder

On Error GoTo ErrHandler

Set Adder = New DimAdder
Set Adder.Panel = Panel
Set Adder.Vars = Vars
ParseVar Adder, Access, InsideProc, IsStatic, Token, HasDefault
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseDim"
ErrReraise
End Sub

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

On Error GoTo ErrHandler
Set Ent = New Entity
Set Udt = New TypeConstruct
Udt.Access = Access

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

Set Udt.Id = NewId(Token)
SymTable.Add Udt, Panel, IsStdLib:=Panel.Entity.StdLib

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

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

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

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

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

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

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

Name = NameBank(Udt.Id.Name)
CheckDupl Panel.Entity, Var.Id.Name
Panel.Entity.Types.Add Udt, Name
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseType"
ErrReraise
End Sub

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

On Error GoTo ErrHandler
Set Xp = New Expressionist

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

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

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

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

Select Case Token.Kind
Case tkKeyword
Select Case Token.Code
Case kwCall
Set Stmt = Xp.GetStmt(Me)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail Token, m.ExpEqArg
Debug.Assert Stmt.Kind = snCall
Body.Add Stmt

Case kwClose
Set LookAhead = ParseClose(Body)

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

Case kwContinue
ParseContinue Panel, Body

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

Case kwDo
ParseDo Panel, Body

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

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

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

Body.Add New EndConstruct

Case kwErase
Set LookAhead = ParseErase(Body)

Case kwExit
ParseExit Panel, Body

Case kwFor
Set LookAhead = ParseFor(Panel, Body)

Case kwGet
ParseGet Body

Case kwGoSub
ParseGoSub Panel, Body

Case kwGoTo
ParseGoTo Panel, Body

Case kwIf
Set LookAhead = ParseIf(Panel, Body)

Case kwInput
Set LookAhead = ParseInput(Body)

Case kwLet
Set Stmt = Xp.GetStmt(Me)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail Token, m.ExpEqArg
Debug.Assert Stmt.Kind = snLet
Body.Add Stmt

Case kwLSet
Set LookAhead = ParseLSet(Body)

Case kwOn
Set LookAhead = ParseOn(Panel, Body)

Case kwOpen
Set LookAhead = ParseOpen(Body)

Case kwPrint
Set LookAhead = ParsePrint(Body)

Case kwPut
ParsePut Body

Case kwRaiseEvent
Set LookAhead = ParseRaiseEvent(Body)

Case kwReDim
ParseReDim Panel, Body

Case kwResume
Set LookAhead = ParseResume(Panel, Body)

Case kwReturn
Body.Add New ReturnConstruct

Case kwRSet
Set LookAhead = ParseRSet(Body)

Case kwSeek
Set LookAhead = ParseSeek(Body)

Case kwSelect
ParseSelect Panel, Body

Case kwSet
Set Stmt = Xp.GetStmt(Me)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail Token, m.ExpEqArg
Debug.Assert Stmt.Kind = snLet

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

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

Case kwStop
Body.Add New StopConstruct

Case kwUnlock
Set LookAhead = ParseUnlock(Body)

Case kwWhile
ParseWhile Panel, Body

Case cxWidth
Set LookAhead = ParseWidth(Body)

Case kwWith
ParseWith Panel, Body

Case kwWrite
Set LookAhead = ParseWrite(Body)

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

Case cxName
Set LookAhead = ParseName(Body)

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

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

Case cxReset
Body.Add New ResetConstruct

Case cxWidth
Set LookAhead = ParseWidth(Body)

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

Case tkEscapedIdentifier
GoTo Up

Case tkDirective
ParseDirective Token

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

Case Else
Fail Token, m.ExpStmt
End Select

Case tkHardLineBreak
Rem Nothing to do

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

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

Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseBody"
ErrReraise
End Function

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

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

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

On Error GoTo ErrHandler
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt = New CloseConstruct

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

Stmt.FileNumbers.Add Expr
Loop While Token.Kind = tkListSeparator

Body.Add Stmt
Set ParseClose = Token
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseClose"
ErrReraise
End Function

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

On Error GoTo ErrHandler
Set Stmt = New ContinueConstruct
Set Token = NextToken

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

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

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

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

Body.Add Stmt
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseContinue"
ErrReraise
End Sub

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

On Error GoTo ErrHandler
Set Xp = New Expressionist
Xp.FullMode = True

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

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

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

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

Set Token = NextToken
Set Mark = Token

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

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

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

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseDo"
ErrReraise
End Sub

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

On Error GoTo ErrHandler
Set Stmt = New EraseConstruct

Do
Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, m.RuleErase, m.IdName

Set Sym = New Symbol
Set Sym.Value = Token
Stmt.Vars.Add Sym

Set Token = NextToken
Loop While Token.Kind = tkListSeparator

Body.Add Stmt
Set ParseErase = Token
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseErase"
ErrReraise
End Function

Private Sub ParseExit(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As ExitConstruct

On Error GoTo ErrHandler
Set Stmt = New ExitConstruct
Set Token = NextToken

If Token.IsKeyword(kwDo) Then
If Panel.DoCount = 0 Then Fail Token, m.ExitNonDo
Stmt.What = ewDo

ElseIf Token.IsKeyword(kwFor) Then
If Panel.ForCount = 0 Then Fail Token, m.ExitNonFor
Stmt.What = ewFor

ElseIf Token.IsKeyword(kwWhile) Then
If Panel.WhileCount = 0 Then Fail Token, m.ExitNonWhile
Stmt.What = ewWhile

ElseIf Token.IsKeyword(kwSub) Then
If Panel.BodyType <> ewSub Then Fail Token, m.ExitNonSub
Stmt.What = ewSub

ElseIf Token.IsKeyword(kwFunction) Then
If Panel.BodyType <> ewFunction Then Fail Token, m.ExitNonFunc
Stmt.What = ewFunction

ElseIf Token.IsId(cxProperty) Then
If Panel.BodyType <> ewProperty Then Fail Token, m.ExitNonProp
Stmt.What = ewProperty

ElseIf Token.IsKeyword(kwSelect) Then
If Panel.SelectCount = 0 Then Fail Token, m.ExitNonSelect
Stmt.What = ewSelect

Else
Fail Token, m.ExpDoForEtc
End If

Body.Add Stmt
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseExit"
ErrReraise
End Sub

Private Function ParseFor(ByVal Panel As ControlPanel, ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Mark As Token
Dim Lit As Literal
Dim Expr As IExpression
Dim Stmt As ForConstruct
Dim Xp As Expressionist
Dim Bin As BinaryExpression

On Error GoTo ErrHandler
Set Xp = New Expressionist
Xp.FullMode = True
Xp.CanHaveTo = True
Set Token = NextToken

If Token.IsKeyword(kwEach) Then
ParseForEach Panel, Body
Exit Function
End If

Set Stmt = New ForConstruct
EnsureIdExists Token
If Not IsProperId(Token) Then Fail Token, m.RuleFor, m.IdName

Set Stmt.Counter = New Symbol
Set Stmt.Counter.Value = Token

Set Token = NextToken
If Not Token.IsOperator(opEq) Then Fail Token, m.RuleFor, m.Equal
Set Mark = Token

Set Expr = Xp.GetExpression(Me)
Set Token = Xp.LastToken

If Expr Is Nothing Then Fail Mark, m.InvExpr
If Expr.Kind <> ekBinaryExpr Then Fail Mark, m.InvExpr
Set Bin = Expr
If Not Bin.Operator.Value.Code = opTo Then Fail Token, m.RuleFor, v.To

Set Stmt.StartValue = Bin.LHS
Set Stmt.EndValue = Bin.RHS

If Token.IsId(cxStep) Then
Set Mark = Token
Xp.CanHaveTo = False
Set Stmt.Increment = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.Increment Is Nothing Then Fail Mark, m.RuleFor, m.Increment
Else
Set Lit = New Literal
Set Lit.Value = New Token
Lit.Value.Kind = tkIntegerNumber
Lit.Value.Text = "1"
Lit.Value.Code = vbInteger
Set Stmt.Increment = Lit
End If

If Not IsBreak(Token) Then Fail Token, m.ExpEOS
Panel.ForCount = Panel.ForCount + 1
Set Token = ParseBody(Panel, Stmt.Body)
Panel.ForCount = Panel.ForCount - 1
If Not Token.IsKeyword(kwNext) Then Fail Token, m.ExpNext

Set Token = NextToken

If IsProperId(Token) And Token.Code = Stmt.Counter.Value.Code Then
Rem Next token should be a line-break or a comma.
Set Token = NextToken

If Token.Kind = tkListSeparator Then
Set Token = New Token
Token.Kind = tkKeyword
Token.Code = kwNext

ElseIf IsBreak(Token) Then
Rem OK

Else
Fail Token, m.ExpEOS
End If

ElseIf IsBreak(Token) Then
Rem OK

Else
Fail Token, m.ExpEOS
End If

Body.Add Stmt
Set ParseFor = Token
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseFor"
ErrReraise
End Function

Private Sub ParseForEach(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As ForEachConstruct
Dim Xp As Expressionist

On Error GoTo ErrHandler
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt = New ForEachConstruct
Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token) Then Fail Token, m.RuleForEach, m.VariableName

Set Stmt.Element = New Symbol
Set Stmt.Element.Value = Token

Set Token = NextToken
If Not Token.IsKeyword(kwIn) Then Fail Token, m.RuleForEach, v.In

Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, m.RuleForEach, m.GroupName
Set Stmt.Group = Xp.GetStmt(Me, Token)
If Stmt.Group Is Nothing Then Fail Token, m.RuleForEach, m.GroupName

Set Token = Xp.LastToken
If Not IsBreak(Token) Then Fail Token, m.ExpEOS

Panel.ForCount = Panel.ForCount + 1
Set Token = ParseBody(Panel, Stmt.Body)
Panel.ForCount = Panel.ForCount - 1
If Not Token.IsKeyword(kwNext) Then Fail Token, m.ExpNext

MustEatLineBreak
Body.Add Stmt
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseForEach"
ErrReraise
End Sub

Private Sub ParseGet(ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As GetConstruct
Dim Xp As Expressionist

On Error GoTo ErrHandler
Set Stmt = New GetConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken

If Stmt.FileNumber Is Nothing Then Fail Token, m.RuleGet, m.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Token, m.RuleGet, m.Comma

Set Stmt.RecNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken
Rem RecNumber can be nothing
If Token.Kind <> tkListSeparator Then Fail Token, m.RuleGet, m.Comma

Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, m.RuleGet, m.VariableName

Set Stmt.Var = New Symbol
Set Stmt.Var.Value = Token
Body.Add Stmt
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseGet"
ErrReraise
End Sub

Private Sub ParseGoSub(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As GoSubConstruct
Dim Label As LabelConstruct
Dim LinNum As LineNumberConstruct

On Error GoTo ErrHandler
Set Stmt = New GoSubConstruct
Set Token = NextToken

Select Case Token.Kind
Case tkIdentifier, tkEscapedIdentifier, tkCrazyIdentifier
EnsureIdExists Token
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Set Stmt.Target = Label
Panel.AddTarget Label

Case tkIntegerNumber
If Left$(Token.Text, 1) = "-" Then Fail Token, m.ExpTarget
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token

Set Stmt.Target = LinNum
Panel.AddTarget LinNum

Case Else
Fail Token, m.ExpTarget
End Select

Body.Add Stmt
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseGoSub"
ErrReraise
End Sub

Private Sub ParseGoTo(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As GoToConstruct
Dim Label As LabelConstruct
Dim LinNum As LineNumberConstruct

On Error GoTo ErrHandler
Set Stmt = New GoToConstruct
Set Token = NextToken

Select Case Token.Kind
Case tkIdentifier, tkEscapedIdentifier, tkCrazyIdentifier
EnsureIdExists Token
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Set Stmt.Target = Label
Panel.AddTarget Label

Case tkIntegerNumber
If Left$(Token.Text, 1) = "-" Then Fail Token, m.ExpTarget
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token

Set Stmt.Target = LinNum
Panel.AddTarget LinNum

Case Else
Fail Token, m.ExpTarget
End Select

Body.Add Stmt
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseGoTo"
ErrReraise
End Sub

Private Function ParseIf(ByVal Panel As ControlPanel, ByVal Body As KeyedList) As Token
Dim Arm As IfArm
Dim Token As Token
Dim Stmt As IfConstruct
Dim Xp As Expressionist

On Error GoTo ErrHandler
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt = New IfConstruct

Set Arm = New IfArm
Rem If <condition> ?
Set Token = NextToken
Set Arm.Condition = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken
If Arm.Condition Is Nothing Then Fail Token, m.InvExpr

Rem If <condition> Then ?
If Not Token.IsKeyword(kwThen) Then Fail Token, m.RuleIf, v.Then

Stmt.Arms.Add Arm
Set Token = NextToken

If Token.Kind = tkSoftLineBreak Then
Rem If <condition> Then :
Do
Set Token = NextToken
If IsHardBreak(Token) Then Exit Do
Up:
If Not IsStatement(Token) Then Fail Token, m.ExpStmt

Rem If <condition> Then : <statement>
Set Token = ParseBody(Panel, Arm.Body, IsSingleLine:=True, LookAhead:=Token)
Loop While Token.Kind = tkSoftLineBreak

If Token.IsKeyword(kwElse) Then
Rem If <condition> Then : <statement> Else
Set Token = NextToken

Do
If Token.Kind = tkSoftLineBreak Then Set Token = NextToken
If Not IsStatement(Token) Then Fail Token, m.ExpStmt

Set Token = ParseBody(Panel, Stmt.ElseBody, IsSingleLine:=True, LookAhead:=Token)
Loop While Token.Kind = tkSoftLineBreak
End If

If Not IsHardBreak(Token) Then Fail Token, m.ExpEOS

ElseIf IsHardBreak(Token) Then
Set Token = ParseBody(Panel, Arm.Body)
If Token.Kind <> tkKeyword Then Fail Token, m.ExpElseEtc

Do
Select Case Token.Code
Case kwElseIf
Set Arm = New IfArm
Set Arm.Condition = Xp.GetExpression(Me)
If Arm.Condition Is Nothing Then Fail Token, m.InvExpr

Set Token = Xp.LastToken
If Not Token.IsKeyword(kwThen) Then Fail Token, m.RuleIf, v.Then

Set Token = ParseBody(Panel, Arm.Body)
Stmt.Arms.Add Arm

Case kwElse
Set Token = NextToken
If Not IsHardBreak(Token) Then Fail Token, m.ExpEOS

Set Token = ParseBody(Panel, Stmt.ElseBody)

If Token.IsKeyword(kwIf) Then
Set Token = NextToken
Exit Do
End If

Fail Token, m.ExpEnd & v.If

Case kwIf
Set Token = NextToken
Exit Do

Case Else
Fail Token, m.ExpElseEtc
End Select
Loop

ElseIf IsStatement(Token) Then
GoTo Up

Else
Fail Token, m.NonEndIf
End If

Body.Add Stmt
Set ParseIf = Token
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseIf"
ErrReraise
End Function

Private Function ParseInput(ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Sym As Symbol
Dim Xp As Expressionist
Dim Stmt As InputConstruct

Debug.Assert False 'TODO: Test
On Error GoTo ErrHandler
Set Stmt = New InputConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.FileNumber Is Nothing Then Fail Token, m.RuleInput, m.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Token, m.RuleInput, m.Comma

Do
Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, m.RuleInput, m.VariableName

Set Sym = New Symbol
Set Sym.Value = NewId(Token)
Stmt.Vars.Add Sym

Set Token = NextToken
Loop While Token.Kind = tkListSeparator

Body.Add Stmt
Set ParseInput = Token
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseInput"
ErrReraise
End Function

Private Function ParseLock(ByVal Body As KeyedList) As Token
Dim Stmt As LockConstruct
Dim Xp As Expressionist

On Error GoTo ErrHandler
Set Stmt = New LockConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RuleLock, m.HashFileNumber

If Xp.LastToken.Kind = tkListSeparator Then
Xp.CanHaveTo = True
Set Stmt.RecordRange = Xp.GetExpression(Me)
If Stmt.RecordRange Is Nothing Then Fail Xp.LastToken, m.RuleLock, m.RecordRange
End If

Body.Add Stmt
Set ParseLock = Xp.LastToken
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseLock"
ErrReraise
End Function

Private Function ParseLSet(ByVal Body As KeyedList) As Token
Dim ISt As IStmt
Dim Mark As Token
Dim Asg As LetConstruct
Dim Xp As Expressionist
Dim Stmt As LSetConstruct

On Error GoTo ErrHandler
Set Xp = New Expressionist
Set Stmt = New LSetConstruct

Set Mark = NextToken
Set ISt = Xp.GetStmt(Me, Mark)
Debug.Assert ISt.Kind = snLet

Set Asg = ISt
If Asg.Name.Kind <> ekSymbol Then Fail Mark, m.ExpVarId
If Asg.Operator.Value.Code <> opEq Then Fail Asg.Operator.Value, m.RuleLSet, m.Equal

Set Stmt.Name = Asg.Name
Set Stmt.Value = Asg.Value
Body.Add Stmt
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseLSet"
ErrReraise
End Function

Private Function ParseName(ByVal Body As KeyedList) As Token
Dim Xp As Expressionist
Dim Stmt As NameConstruct

On Error GoTo ErrHandler
Set Stmt = New NameConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.OldPathName = Xp.GetExpression(Me)
If Stmt.OldPathName Is Nothing Then Fail Xp.LastToken, m.RuleName, m.OldPathName
If Not Xp.LastToken.IsKeyword(kwAs) Then Fail Xp.LastToken, m.RuleName, v.As

Set Stmt.NewPathName = Xp.GetExpression(Me)
If Stmt.NewPathName Is Nothing Then Fail Xp.LastToken, m.RuleName, m.NewPathName

Body.Add Stmt
Set ParseName = Xp.LastToken
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseName"
ErrReraise
End Function

Private Function ParseOn(ByVal Panel As ControlPanel, ByVal Body As KeyedList) As Token
Dim Token As Token
Dim WentTo As GoToConstruct
Dim Label As LabelConstruct
Dim ResStmt As ResumeConstruct
Dim OnStmt As OnErrorConstruct
Dim Xp As New Expressionist
Dim Comp As OnComputedConstruct
Dim LinNum As LineNumberConstruct

On Error GoTo ErrHandler
Set Token = NextToken

If Token.IsKeyword(cxError) Then
Set OnStmt = New OnErrorConstruct
Set Token = NextToken
If Token.IsKeyword(kwLocal) Then Set Token = NextToken

If Token.IsKeyword(kwGoTo) Then
Set Token = NextToken

Select Case Token.Kind
Case tkIntegerNumber
If Left$(Token.Text, 1) = "-" Then Fail Token, m.ExpTarget
Set WentTo = New GoToConstruct
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token
Set WentTo.Target = LinNum
Set OnStmt.Statement = WentTo
Panel.AddTarget LinNum

Case tkIdentifier, tkEscapedIdentifier, tkCrazyIdentifier
EnsureIdExists Token
Set WentTo = New GoToConstruct
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Set WentTo.Target = Label
Set OnStmt.Statement = WentTo
Panel.AddTarget Label

Case Else
Fail Token, m.ExpTarget
End Select

ElseIf Token.IsKeyword(kwResume) Then
Set Token = NextToken
If Not Token.IsKeyword(kwNext) Then Fail Token, m.ExpNext

Set ResStmt = New ResumeConstruct
ResStmt.IsNext = True
Set OnStmt.Statement = ResStmt

Else
Fail Token, m.ExpGoToSub
End If

Set Token = NextToken
Body.Add OnStmt

Else
Set Comp = New OnComputedConstruct
Xp.FullMode = True
Set Comp.Value = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken
If Comp.Value Is Nothing Then Fail Token, m.InvExpr

If Token.IsKeyword(kwGoTo) Then
Comp.IsGoTo = True

ElseIf Token.IsKeyword(kwGoSub) Then
Comp.IsGoTo = False 'Technically, this is not needed

Else
Fail Token, m.ExpGoToSub
End If

Do
Set Token = NextToken

Select Case Token.Kind
Case tkIntegerNumber
If Left$(Token.Text, 1) = "-" Then Fail Token, m.ExpTarget
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token
Comp.Targets.Add LinNum
Panel.AddTarget LinNum

Case tkIdentifier
EnsureIdExists Token
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Comp.Targets.Add Label
Panel.AddTarget Label

Case Else
Fail Token, m.ExpTarget
End Select

Set Token = NextToken
Loop While Token.Kind = tkListSeparator

Body.Add Comp
End If

Set ParseOn = Token
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseOn"
ErrReraise
End Function

Private Function ParseOpen(ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Stmt As OpenConstruct
Dim Xp As Expressionist

On Error GoTo ErrHandler
Set Stmt = New OpenConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.PathName = Xp.GetExpression(Me)
If Stmt.PathName Is Nothing Then Fail Xp.LastToken, m.RuleOpen, m.PathName
If Not Xp.LastToken.IsKeyword(kwFor) Then Fail Xp.LastToken, m.RuleOpen, v.For

Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail Token, m.ExpAppendEtc

Select Case Token.Code
Case cxAppend
Stmt.FileMode = fmAppend

Case cxBinary
Stmt.FileMode = fmBinary

Case kwInput
Stmt.FileMode = fmInput

Case cxOutput
Stmt.FileMode = fmOutput

Case cxRandom
Stmt.FileMode = fmRandom

Case Else
Fail Token, m.ExpAppendEtc
End Select

Set Token = NextToken

If Token.IsKeyword(cxAccess) Then
Set Token = NextToken

If Token.IsKeyword(cxRead) Then
Stmt.FileAccess = faRead
Set Token = NextToken
End If

If Token.IsKeyword(kwWrite) Then
If Stmt.FileAccess = faRead Then Stmt.FileAccess = faReadWrite Else Stmt.FileAccess = faWrite
Set Token = NextToken
End If

If Stmt.FileAccess = faNone Then Fail Token, m.ExpReadWrite
End If

If Token.IsKeyword(cxShared) Then
Stmt.FileLock = flShared
Set Token = NextToken

ElseIf Token.IsKeyword(cxRead) Then
Stmt.FileLock = flRead
Set Token = NextToken

If Token.IsKeyword(kwWrite) Then
Stmt.FileAccess = faReadWrite
Set Token = NextToken
End If

ElseIf Token.IsKeyword(kwWrite) Then
Stmt.FileAccess = faWrite
Set Token = NextToken
End If

If Not Token.IsKeyword(kwAs) Then Fail Token, m.RuleOpen, v.As
Set Stmt.FileNumber = Xp.GetExpression(Me)
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RuleOpen, m.HashFileNumber
Set Token = Xp.LastToken

If Token.IsKeyword(cxLen) Then
Set Token = NextToken
If Not Token.IsOperator(opEq) Then Fail Token, m.RuleOpen, m.Equal

Set Stmt.Length = Xp.GetExpression(Me)
Set Token = Xp.LastToken
End If

Rem TODO: Default Lock and Access
Body.Add Stmt
Set ParseOpen = Token
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseOpen"
ErrReraise
End Function

Private Function ParsePrint(ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Sym As Symbol
Dim Arg As PrintArg
Dim Expr As IExpression
Dim Xp As Expressionist
Dim Exec As CallConstruct
Dim Stmt As PrintConstruct

On Error GoTo ErrHandler
Set Stmt = New PrintConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.FileNumber Is Nothing Then Fail Token, m.RulePrint, m.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Token, m.RulePrint, m.Comma
Set Token = Nothing

Do
Set Expr = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken
If Expr Is Nothing Then Fail Xp.LastToken, m.RulePrint, m.VariableName

Set Arg = New PrintArg

If Expr.Kind = ekIndexer Then
Set Exec = Expr

If Exec.LHS.Kind = ekSymbol Then
Set Sym = Exec.LHS

If Sym.Value.IsId(cxSpc) Then
If Exec.Arguments.Count <> 1 Then Fail Sym.Value, m.WrongNumArg
Set Arg.Indent = New PrintIndent
Set Arg.Indent.Value = Exec.Arguments(1)
Set Expr = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken

ElseIf Sym.Value.IsId(cxTab) Then
If Exec.Arguments.Count > 1 Then Fail Sym.Value, m.WrongNumArg
Set Arg.Indent = New PrintIndent
Arg.Indent.IsTab = True
Set Arg.Indent.Value = Exec.Arguments(1)
Set Expr = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken
End If
End If

ElseIf Expr.Kind = ekSymbol Then
Set Sym = Expr

If Sym.Value.IsId(cxTab) Then
Set Arg.Indent = New PrintIndent
Arg.Indent.IsTab = True
Set Expr = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken
End If
End If

Set Arg.Value = Expr

If Token.Kind = tkPrintSeparator Then
Arg.HasSemicolon = True
Set Token = NextToken
End If

Stmt.Output.Add Arg
Loop Until IsEndOfContext(Token)

Body.Add Stmt
Set ParsePrint = Token
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParsePrint"
ErrReraise
End Function

Private Sub ParsePut(ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As PutConstruct
Dim Xp As Expressionist

On Error GoTo ErrHandler
Set Stmt = New PutConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken

If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RulePut, m.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, m.RulePut, m.Comma

Set Stmt.RecNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken
Rem RecNumber can be nothing
If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, m.RulePut, m.Comma

Set Token = NextToken
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, m.RulePut, m.IdName

Set Stmt.Var = New Symbol
Set Stmt.Var.Value = Token
Body.Add Stmt
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParsePut"
ErrReraise
End Sub

Private Function ParseRaiseEvent(ByVal Body As KeyedList) As Token
Dim Token As Token
Dim ISt As IStmt
Dim Sym As Symbol
Dim Xp As Expressionist
Dim Exec As CallConstruct
Dim Stmt As RaiseEventConstruct

On Error GoTo ErrHandler
Set Stmt = New RaiseEventConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set ISt = Xp.GetStmt(Me)
Set Token = Xp.LastToken
Debug.Assert ISt.Kind = snCall

Set Exec = ISt
Debug.Assert Exec.LHS.Kind = ekSymbol

Set Sym = Exec.LHS
If Sym.Value.Code = 0 Then Fail Token, m.ExpEvtName

Set Stmt.Id = NewId(Sym.Value)
Set Stmt.Arguments = Exec.Arguments

Body.Add Stmt
Set ParseRaiseEvent = Token
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseRaiseEvent"
ErrReraise
End Function

Private Sub ParseReDim(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Var As Variable
Dim Adder As IVarAdder
Dim Stmt As ReDimConstruct

On Error GoTo ErrHandler

Set Stmt = New ReDimConstruct
Set Token = NextToken

Set Adder = New ReDimAdder
Set Adder.Panel = Panel
Set Adder.Vars = Stmt.Vars

If Token.IsKeyword(kwPreserve) Then
Stmt.HasPreserve = True
Set Token = NextToken
End If

Rem TODO: Adder below is checking whether Var exists in entity's scope or not, but we may be ReDim'ming a global
Rem variable in another entity (module). We are not checking it yet.
ParseVar Adder, acLocal, InsideProc:=True, Token:=Token

Rem TODO: We need to check that only last dimension changed.
Rem Also, if a data type was specified, we must check it matches the previous one.

For Each Var In Stmt.Vars
If Var.HasNew Then Fail Var.Id.Name, m.InvUseOf & NameBank.Operators(NameBank.FromCtxIndex(opNew))
If Not Var.Init Is Nothing Then Fail Var.Id.Name, m.UnexpInit
If Var.Subscripts.Count = 0 Then Fail Var.Id.Name, m.ExpSubscript

Next

Body.Add Stmt
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseReDim"
ErrReraise
End Sub

Private Function ParseResume(ByVal Panel As ControlPanel, ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Label As LabelConstruct
Dim Stmt As ResumeConstruct
Dim LinNum As LineNumberConstruct

On Error GoTo ErrHandler
Set Stmt = New ResumeConstruct
Set Token = NextToken

Select Case Token.Kind
Case tkIntegerNumber
If Left$(Token.Text, 1) = "-" Then Fail Token, m.InvLinNum
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token
Set Stmt.Target = LinNum
Set Token = NextToken
Panel.AddLine LinNum

Case tkIdentifier, tkEscapedIdentifier, tkCrazyIdentifier
EnsureIdExists Token
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Set Stmt.Target = Label
Set Token = NextToken
Panel.AddLabel Label

Case tkKeyword
If Token.Code <> kwNext Then Fail Token, m.ExpNext
Stmt.IsNext = True
Set Token = NextToken

Case Else
Set LinNum = New LineNumberConstruct
Set LinNum.Value = New Token
LinNum.Value.Kind = tkIntegerNumber
LinNum.Value.Text = "+0"
LinNum.Value.Code = vbInteger
Set Stmt.Target = LinNum
End Select

Body.Add Stmt
Set ParseResume = Token
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseResume"
ErrReraise
End Function

Private Sub ParseSelect(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Expr As IExpression
Dim Xp As Expressionist
Dim Cs As CaseConstruct
Dim Stmt As SelectConstruct
Dim IsExpr As BinaryExpression

On Error GoTo ErrHandler
Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt = New SelectConstruct

Set Token = NextToken
If Not Token.IsKeyword(kwCase) Then Fail Token, m.RuleSelect, v.Case

Set Stmt.Value = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.Value Is Nothing Then Fail Token, m.InvExpr
If Not IsBreak(Token) Then Fail Token, m.ExpEOS
Panel.SelectCount = Panel.SelectCount + 1

Rem From now on we'll accept the "To" operator
Xp.CanHaveTo = True

Do
Rem We can have a "look-ahead" token Case from ParseBody below.
Rem After parsing the statement block it may have stumbled upon "Case Else", for instance.
If Not Token.IsKeyword(kwCase) Then Set Token = SkipLineBreaks

Rem We will have this situation if there's an empty Select Case like:
Rem Select Case Abc
Rem End Select
If Token.IsKeyword(kwEnd) Then
Set Token = NextToken
If Token.IsKeyword(kwSelect) Then Exit Do
Fail Token, m.ExpEnd & v.Select
End If

Debug.Assert Token.IsKeyword(kwCase)
Set Cs = New CaseConstruct

Do
Set Expr = Xp.GetExpression(Me)
Set Token = Xp.LastToken

If Expr Is Nothing Then
If Token.IsOperator(opIs) Then
Rem We have an "Is" expression
Set IsExpr = New BinaryExpression
Rem IsExpr.LHS will be Nothing

Set Token = NextToken
If Token.Kind <> tkOperator Then Fail Token, m.ExpCompOp

Set IsExpr.Operator = NewOperator(Token)
If IsExpr.Operator.IsUnary Then Fail Token, m.ExpCompOp

Set IsExpr.RHS = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If IsExpr.RHS Is Nothing Then Fail Token, m.InvExpr

Set Expr = IsExpr

ElseIf Token.IsKeyword(kwElse) Then
Rem We have a "Case Else".
Set Token = ParseBody(Panel, Stmt.CaseElse)
If Not Token.IsKeyword(kwSelect) Then Fail Token, m.ExpEnd & v.Select

Rem Cs must not be added after Loop
Set Cs = Nothing
Exit Do

Else
Debug.Assert False
Fail Token, m.ExpIsElse
End If
End If

Cs.Conditions.Add Expr

If IsBreak(Token) Then
Set Token = ParseBody(Panel, Cs.Body)
Exit Do
End If

If Token.Kind <> tkListSeparator Then Fail Token, m.CommaOrEOS
Loop

If Not Cs Is Nothing Then Stmt.Cases.Add Cs
Loop Until Token.IsKeyword(kwSelect)

Panel.SelectCount = Panel.SelectCount - 1
Body.Add Stmt
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseSelect"
ErrReraise
End Sub

Private Function ParseRSet(ByVal Body As KeyedList) As Token
Dim ISt As IStmt
Dim Mark As Token
Dim Asg As LetConstruct
Dim Xp As Expressionist
Dim Stmt As RSetConstruct

On Error GoTo ErrHandler
Set Xp = New Expressionist
Set Stmt = New RSetConstruct

Set Mark = NextToken
Set ISt = Xp.GetStmt(Me, Mark)
Debug.Assert ISt.Kind = snLet

Set Asg = ISt
If Asg.Name.Kind <> ekSymbol Then Fail Mark, m.ExpVarId
If Asg.Operator.Value.Code <> opEq Then Fail Asg.Operator.Value, m.RuleRSet, m.Equal

Set Stmt.Name = Asg.Name
Set Stmt.Value = Asg.Value
Body.Add Stmt
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseRSet"
ErrReraise
End Function

Private Function ParseSeek(ByVal Body As KeyedList) As Token
Dim Xp As Expressionist
Dim Stmt As SeekConstruct

On Error GoTo ErrHandler
Set Stmt = New SeekConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RuleSeek, m.HashFileNumber
If Xp.LastToken.Kind <> tkListSeparator Then Fail Xp.LastToken, m.RuleSeek, m.Comma

Set Stmt.Position = Xp.GetExpression(Me)
If Stmt.Position Is Nothing Then Fail Xp.LastToken, m.PositionName

Body.Add Stmt
Set ParseSeek = Xp.LastToken
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseSeek"
ErrReraise
End Function

Private Function ParseUnlock(ByVal Body As KeyedList) As Token
Dim Stmt As UnlockConstruct
Dim Xp As Expressionist

On Error GoTo ErrHandler
Set Stmt = New UnlockConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RuleUnlock, m.HashFileNumber

If Xp.LastToken.Kind = tkListSeparator Then
Xp.CanHaveTo = True
Set Stmt.RecordRange = Xp.GetExpression(Me)
If Stmt.RecordRange Is Nothing Then Fail Xp.LastToken, m.RuleUnlock, m.RecordRange
End If

Body.Add Stmt
Set ParseUnlock = Xp.LastToken
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseUnlock"
ErrReraise
End Function

Private Sub ParseWhile(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Xp As Expressionist
Dim Stmt As WhileConstruct

On Error GoTo ErrHandler
Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt = New WhileConstruct

Set Stmt.Condition = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.Condition Is Nothing Then Fail Token, m.InvExpr

If Not IsBreak(Token) Then Fail Token, m.ExpEOS
Panel.WhileCount = Panel.WhileCount + 1
Set Token = ParseBody(Panel, Stmt.Body)
Panel.WhileCount = Panel.WhileCount - 1

If Token.IsKeyword(kwWend) Then
Rem OK

ElseIf Token.IsKeyword(kwWhile) Then
Rem OK

Else
Fail Token, m.ExpWend
End If

MustEatLineBreak
Body.Add Stmt
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseWhile"
ErrReraise
End Sub

Private Function ParseWidth(ByVal Body As KeyedList) As Token
Dim Stmt As WidthConstruct
Dim Xp As Expressionist

On Error GoTo ErrHandler
Set Stmt = New WidthConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RuleWidth, m.HashFileNumber
If Xp.LastToken.Kind <> tkListSeparator Then Fail Xp.LastToken, m.RuleWidth, m.Comma

Xp.CanHaveTo = True
Set Stmt.Value = Xp.GetExpression(Me)
If Stmt.Value Is Nothing Then Fail Xp.LastToken, m.RuleWidth, m.WidthName

Body.Add Stmt
Set ParseWidth = Xp.LastToken
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseWidth"
ErrReraise
End Function

Private Sub ParseWith(ByVal Panel As ControlPanel, ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As WithConstruct
Dim Xp As Expressionist

On Error GoTo ErrHandler
Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt = New WithConstruct

Set Token = NextToken
EnsureIdExists Token
If Not IsProperId(Token) Then Fail Token, m.RuleWith, m.ObjectName

Set Stmt.PinObject = Xp.GetStmt(Me, Token)
Set Token = Xp.LastToken
If Stmt.PinObject Is Nothing Then Fail Token, m.RuleWith, m.ObjectName


Set Token = ParseBody(Panel, Stmt.Body, LookAhead:=Token)
If Not Token.IsKeyword(kwWith) Then Fail Token, m.ExpEnd & v.With

Body.Add Stmt
Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseWith"
ErrReraise
End Sub

Private Function ParseWrite(ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Expr As IExpression
Dim Xp As Expressionist
Dim Stmt As WriteConstruct

On Error GoTo ErrHandler
Set Stmt = New WriteConstruct
Set Xp = New Expressionist
Xp.FullMode = True

Set Stmt.FileNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, m.RuleWrite, m.HashFileNumber
If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, m.RuleWrite, m.Comma

Do
Set Expr = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Expr Is Nothing Then Exit Do

Stmt.Output.Add Expr
Loop While Token.Kind = tkListSeparator

Body.Add Stmt
Set ParseWrite = Token
Exit Function

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseWrite"
ErrReraise
End Function

Private Function AreEqual(ByVal LeftParm As Parameter, ByVal RightParm As Parameter) As Boolean
If LeftParm.DataType.IsArray <> RightParm.DataType.IsArray Then Exit Function
If LeftParm.IsByVal <> RightParm.IsByVal Then Exit Function
If LeftParm.IsOptional <> RightParm.IsOptional Then Exit Function
If LeftParm.IsParamArray <> RightParm.IsParamArray Then Exit Function
If LeftParm.DataType.Id.Name.Code <> RightParm.DataType.Id.Name.Code Then Exit Function
AreEqual = True
End Function

Private Function SynthLower(ByVal Entity As Entity) As IExpression
Dim Token As Token
Dim Lit As Literal

Set Token = New Token
Token.Kind = tkIntegerNumber
Token.Text = CStr(Entity.OptionBase)
Token.Code = vbInteger

Set Lit = New Literal
Set Lit.Value = Token
Set SynthLower = Lit
End Function

Private Sub MustEatLineBreak()
Dim Token As Token

Set Token = NextToken
If IsBreak(Token) Then Exit Sub
Fail Token, m.ExpEOS
End Sub

Private Function SkipLineBreaks() As Token
Dim Token As Token

Do
Set Token = NextToken
Loop While Token.Kind = tkSoftLineBreak Or Token.Kind = tkHardLineBreak Or Token.Kind = tkComment

Set SkipLineBreaks = Token
End Function

Private Function IsProperId(ByVal Token As Token, Optional ByVal CanHaveSuffix As Boolean) As Boolean
If Not CanHaveSuffix And Token.Suffix <> vbNullChar Then Fail Token, m.NoSygil
IsProperId = Token.Kind = tkIdentifier Or Token.Kind = tkEscapedIdentifier
End Function

Friend Function IsHardBreak(ByVal Token As Token) As Boolean
IsHardBreak = Token.Kind = tkHardLineBreak Or Token.Kind = tkComment
End Function

Friend Function IsBreak(ByVal Token As Token) As Boolean
Select Case Token.Kind
Case tkSoftLineBreak, tkHardLineBreak, tkComment, tkEndOfStream
IsBreak = True
End Select
End Function

Private Function IsProperDataType(ByVal Token As Token) As Boolean
If Token.Suffix <> vbNullChar Then Fail Token, m.NoSygil

Select Case Token.Kind
Case tkIdentifier, tkEscapedIdentifier
IsProperDataType = True

Case tkKeyword
IsProperDataType = IsBuiltinDataType(Token)
End Select
End Function

Private Function IsConstDataType(ByVal Token As Token) As Boolean
Select Case Token.Code
Case kwBoolean, kwByte, kwInteger, kwLong, kwLongLong, kwLongPtr, kwCurrency, cxDecimal, _
kwSingle, kwDouble, kwDate, kwString
IsConstDataType = True
End Select
End Function

Private Function IsBuiltinDataType(ByVal Token As Token) As Boolean
Select Case Token.Code
Case cxObject, kwVariant
IsBuiltinDataType = True

Case Else
IsBuiltinDataType = IsConstDataType(Token)
End Select
End Function

Private Function IsDataType(ByVal Token As Token) As Boolean
If Token.Suffix <> vbNullChar Then Fail Token, m.NoSygil

If Token.IsKeyword(kwAny) Then
IsDataType = True
Exit Function
End If

IsDataType = IsProperDataType(Token)
End Function

Private Function IsEndOfContext(ByVal Token As Token) As Boolean
Dim Result As Boolean

Result = IsBreak(Token)
If Not Result Then Result = Token.Kind = tkRightParenthesis
If Not Result Then Result = Token.Kind = tkListSeparator
If Not Result Then Result = Token.Kind = tkPrintSeparator

If Not Result And Token.Kind = tkKeyword Then
Result = Token.Code = kwThen
If Not Result Then Result = Token.Code = kwElse
End If

If Not Result Then Result = Token.IsId(cxStep)
IsEndOfContext = Result
End Function

Private Function FromChar(ByVal TypeDeclarationChar As String) As DataType
Dim Token As Token

Set Token = New Token
Token.Kind = tkKeyword

Select Case TypeDeclarationChar
Case "%"
Token.Code = kwInteger

Case "&"
Token.Code = kwLong

Case "^"
Token.Code = kwLongLong

Case "@"
Token.Code = kwCurrency

Case "!"
Token.Code = kwSingle

Case "#"
Token.Code = kwDouble

Case "$"
Token.Code = kwString

Case Else
Rem It should not happen
Debug.Assert False
End Select

Set FromChar = NewDataType(Token)
End Function

Private Sub CheckDupl(ByVal Entity As Entity, ByVal Token As Token, Optional ByVal JumpProp As Boolean)
Dim Name As String

Name = NameBank(Token)

With Entity
If .Consts.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Enums.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Declares.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Events.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Impls.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Vars.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Types.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Subs.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If .Functions.Exists(Name) Then Fail Token, m.AmbiguousName & Name
If Not JumpProp Then If .Properties.Exists(Name) Then Fail Token, m.AmbiguousName & Name
End With
End Sub

Friend Sub EnsureIdExists(ByVal Token As Token)
Dim Name As String

With NameBank
Name = .Item(Token)
If Not .Ids.Exists(Name) Then .Ids.Add Name, Name
Token.Code = .Ids.IndexOf(Name) + .Contextuals.Count + .Keywords.Count
Token.Kind = tkIdentifier
End With
End Sub

Private Sub ParseDirective(ByVal Token As Token)
Rem TODO: Using Static prevents it to be used when evaluating an #If inside another #If.
Static Bool As Boolean
Static Stage As Integer
Dim Vt As Long
Dim Expr As IExpression
Dim Xp As Expressionist
Dim Cnt As ConstConstruct

On Error GoTo ErrHandler
Set Xp = New Expressionist
Xp.FullMode = True

Do
If Token.Kind = tkEndOfStream Then Fail Token, m.EndDirective

Select Case Token.Code
Case kwIf
If Stage <> 0 Then Fail Token, m.ExpDirective
Stage = 1
GoSub CheckCondition

Case kwElseIf
If Stage = 0 Or Stage > 2 Then Fail Token, m.WrongDirective
Stage = 2

If Bool Then
GoSub DiscardSection
Else
GoSub CheckCondition
End If

Case kwElse
If Stage = 0 Or Stage = 3 Then Fail Token, m.WrongDirective
Stage = 3

If Not Bool Then Exit Do
GoSub DiscardSection

Case kwEnd
If Stage = 0 Then Fail Token, m.WrongDirective
Stage = 0

Set Token = NextToken
If Not Token.IsKeyword(kwIf) Then Fail Token, m.EndDirective

Bool = False
Exit Do

Case kwConst
Do
Set Token = NextToken
If Not IsProperId(Token) Then Fail Token, m.RuleConst, m.IdName

Set Cnt = New ConstConstruct
Set Cnt.Id = NewId(Token)

Set Token = NextToken
If Not Token.IsOperator(opEq) Then Fail Token, m.RuleConst, m.Equal

Set Expr = Xp.GetExpression(Me)
If Expr Is Nothing Then Fail Token, m.InvExpr
If Not IsConstant(Expr) Then Fail Token, m.ConstExprReq

Set Cnt.Value = Expr
Vt = InferType(Source_.Path, Expr)

CompileConsts.Add Item:=EvaluateDirective(Source_.Path, Cnt.Value), Key:=NameBank(Cnt.Id.Name)
Set Token = Xp.LastToken
Loop While Token.Kind = tkListSeparator

If Token.Kind <> tkHardLineBreak Then Fail Token, m.ExpEOS
Exit Do
End Select
Loop

Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseDirective"
ErrReraise
Exit Sub

DiscardSection:
Do
Do
Set Token = NextToken
Loop Until IsBreak(Token)

Set Token = NextToken
Loop Until Token.Kind = tkDirective

Return

CheckCondition:
Set Expr = Xp.GetExpression(Me)
If Not Xp.LastToken.IsKeyword(kwThen) Then Fail Token, m.RuleDirectiveIf, "#" & v.Then

Bool = CBool(EvaluateDirective(Source_.Path, Expr))

If Not Bool Then Exit Sub
GoSub DiscardSection
Return
End Sub

Private Sub ParseVar( _
ByVal Adder As IVarAdder, _
ByVal Access As Accessibility, _
Optional ByVal InsideProc As Boolean, _
Optional ByVal IsStatic As Boolean, _
Optional ByVal Token As Token, _
Optional HasDefault As Boolean _
)
Dim Name As String
Dim WasArray As Boolean
Dim Var As Variable
Dim Expr As IExpression
Dim Subs As SubscriptPair
Dim Xp As Expressionist
Dim Bin As BinaryExpression

On Error GoTo ErrHandler
Adder.Panel.HadDim = True
If InsideProc Then If Access = acPublic Or Access = acPrivate Then Fail Token, m.NotInsideMethod
If Token Is Nothing Then Set Token = NextToken

Set Xp = New Expressionist
Xp.CanHaveTo = True
Xp.FullMode = True

Do
Set Var = New Variable
Var.Access = Access
Var.IsStatic = IsStatic
Var.IsDefault = HasDefault
HasDefault = False

If Token.IsKeyword(kwWithEvents) Then
If Not Adder.Panel.Entity.IsClass Then Fail Token, m.ValidInClass
If InsideProc Then Fail Token, m.NotInsideMethod

Var.HasWithEvents = True
Set Token = NextToken
End If

EnsureIdExists Token
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, m.RuleDim, m.IdName
Set Var.Id.Name = Token
Set Token = NextToken
WasArray = False

If Token.Kind = tkLeftParenthesis Then
Do
Set Expr = Xp.GetExpression(Me)
Set Token = Xp.LastToken

If Not Expr Is Nothing Then
Select Case Expr.Kind
Case ekLiteral, ekSymbol, ekUnaryExpr
Set Subs = New SubscriptPair
Set Subs.LowerBound = SynthLower(Adder.Panel.Entity)
Set Subs.UpperBound = Expr

Case ekBinaryExpr
Set Bin = Expr
Set Subs = New SubscriptPair

If Bin.Operator.Value.IsOperator(opTo) Then
Set Subs.LowerBound = Bin.LHS
Set Subs.UpperBound = Bin.RHS
Else
Set Subs.LowerBound = SynthLower(Adder.Panel.Entity)
Set Subs.UpperBound = Expr
End If

Case Else
Debug.Assert False
Fail Token, m.InvExpr
End Select

Var.Subscripts.Add Subs
End If

If Token.Kind <> tkListSeparator Then Exit Do
Loop

If Token.Kind <> tkRightParenthesis And Xp.LastToken.Kind <> tkRightParenthesis Then _
Fail Token, m.ParensMismatch

Adder.Panel.HadArray = True
WasArray = True
Set Token = NextToken
End If

If Token.IsKeyword(kwAs) Then
If Var.Id.Name.Suffix <> vbNullChar Then Fail Token, m.IdHasSygil
Set Token = NextToken

If Token.IsOperator(opNew) Then
Var.HasNew = True
Set Token = NextToken
End If

If Not IsProperDataType(Token) Then Fail Token, m.RuleDim, m.DataType
Set Var.DataType = NewDataType(Token)

If Var.HasNew And Var.DataType.Id.Name.Kind = tkKeyword Then _
Fail Token, m.InvUseOf & NameBank.Operators(NameBank.FromCtxIndex(opNew))

Set Token = NextToken

If Token.IsOperator(opDot) Then
Set Token = NextToken

If Not IsProperDataType(Token) Then Fail Token, m.RuleDim, m.IdName
Set Var.DataType.Id.Name = Token

Set Token = NextToken
End If

ElseIf Var.Id.Name.Suffix <> vbNullChar Then
Set Var.DataType = FromChar(Var.Id.Name.Suffix)

Else
Set Var.DataType = Adder.Panel.Entity.DefTypes(NameBank(Var.Id.Name))
End If

If Token.IsOperator(opMul) Then
Set Var.DataType.FixedLength = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Var.DataType.FixedLength Is Nothing Then Fail Token, m.InvExpr
End If

Var.DataType.IsArray = WasArray
If Var.HasNew And Var.DataType.IsArray Then _
Fail Token, m.InvUseOf & NameBank.Operators(NameBank.FromCtxIndex(opNew))

If Token.IsOperator(opEq) Then
Set Var.Init = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Var.Init Is Nothing Then Fail Token, m.InvExpr
End If

Name = NameBank(Var.Id.Name)
If Not InsideProc Then CheckDupl Adder.Panel.Entity, Var.Id.Name
If Adder.Vars.Exists(Name) Then Fail Token, m.AmbiguousName & Name
Adder.Add Source_.Path, Var, Name

If IsBreak(Token) Then Exit Do
If Token.Kind <> tkListSeparator Then Fail Token, m.RuleDim, m.Comma
Set Token = NextToken
Loop

Exit Sub

ErrHandler:
If Err <> vbObjectError + 13 Then Debug.Print "ParseVar"
ErrReraise
End Sub

Private Sub Fail(ByVal Token As Token, ByVal Message As String, Optional ByVal Expected As String)
Utils.Fail Source_, Token, Message, Expected
End Sub
End Class


Public Class PINQ
Option Explicit
Implements KeyedList

Private MyBase_ As KeyedList

Public Enum PINQOperators
[>]
[>=]
[=]
[<=]
[<]
[<>]
[Like]
[In]
[And]
[Or]
[Desc]
End Enum

Private Sub Class_Initialize()
Set MyBase_ = New KeyedList
End Sub

Private Sub KeyedList_Add(ByVal Item As Variant, Optional ByVal Key As Variant, Optional Position As Variant)
MyBase_.Add Item, Key, Position
End Sub

Private Sub KeyedList_AddKeyValue(ByVal Key As String, ByVal Item As Variant)
MyBase_.AddKeyValue Key, Item
End Sub

Private Sub KeyedList_AddKVPairs(ParamArray KeyValuePairs() As Variant)
Dim Idx As Long

For Idx = 0 To UBound(KeyValuePairs) Step 2
MyBase_.Add KeyValuePairs(Idx + 1), KeyValuePairs(Idx)
Next
End Sub

Private Sub KeyedList_AddValues(ParamArray Values() As Variant)
Dim Idx As Long

For Idx = 0 To UBound(Values)
MyBase_.Add Values(Idx)
Next
End Sub

Private Property Let KeyedList_Base(ByVal RHS As Integer)
MyBase_.Base = RHS
End Property

Private Property Get KeyedList_Base() As Integer
KeyedList_Base = MyBase_.Base
End Property

Private Sub KeyedList_Clear()
MyBase_.Clear
End Sub

Private Property Let KeyedList_CompareMode(ByVal RHS As VbCompareMethod)
MyBase_.CompareMode = RHS
End Property

Private Property Get KeyedList_CompareMode() As VbCompareMethod
KeyedList_CompareMode = MyBase_.CompareMode
End Property

Private Property Get KeyedList_Count() As Long
KeyedList_Count = MyBase_.Count
End Property

Private Property Get KeyedList_Exists(ByVal Key As String) As Boolean
KeyedList_Exists = MyBase_.Exists(Key)
End Property

Private Property Get KeyedList_IndexOf(ByVal Key As String) As Long
KeyedList_IndexOf = MyBase_.IndexOf(Key)
End Property

Private Property Get KeyedList_Item(ByVal Index As Variant) As Variant
If IsObject(MyBase_(Index)) Then
Set KeyedList_Item = MyBase_(Index)
Else
KeyedList_Item = MyBase_(Index)
End If
End Property

Private Function KeyedList_NewEnum() As stdole.IUnknown
Set KeyedList_NewEnum = MyBase_.NewEnum
End Function

Private Property Let KeyedList_ReadOnly(ByVal RHS As Boolean)
MyBase_.ReadOnly = RHS
End Property

Private Property Get KeyedList_ReadOnly() As Boolean
KeyedList_ReadOnly = MyBase_.ReadOnly
End Property

Private Sub KeyedList_Remove(ByVal Index As Variant)
MyBase_.Remove Index
End Sub

Private Property Set KeyedList_T(ByVal RHS As IKLValidator)
Set MyBase_.T = RHS
End Property

Public Iterator Function NewEnum() As IUnknown
Set NewEnum = KeyedList_NewEnum
End Function

Public Property Get ToList() As KeyedList
Set ToList = MyBase_
End Property

Public Default Property Get Item(ByVal Name As String) As Field
Set Item = New Field
Item.Name = Name
End Property

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Property Get From(ByVal Value As KeyedList) As PINQ
Set MyBase_ = Value
Set From = Me
End Property

Public Property Get Where(ParamArray Conditions() As Variant) As PINQ
Const Msg1 = "Expected: Field name or expression"
Const Msg2 = "Expected: Comparison operator"

Dim Keep As Boolean
Dim IsFirst As Boolean
Dim Idx As Long
Dim Jdx As Long
Dim Udx As Long
Dim Obj As Object
Dim LHS As Variant
Dim RHS As Variant
Dim Prop As Variant
Dim Op As OperatorNumbers
Dim Connect As OperatorNumbers

If MyBase_.Count > 0 Then
IsFirst = True
Idx = -1
Udx = UBound(Conditions)
ReDim Keeps(1 To MyBase_.Count) As Boolean

Do
Idx = Idx + 1
If Idx > Udx Then Err.Raise 5, TypeName(Me), Msg1

Idx = Idx + 1
If Idx > Udx Then Err.Raise 5, TypeName(Me), Msg2

Idx = Idx + 1
If Idx > Udx Then Err.Raise 5, TypeName(Me), Msg1

Op = Conditions(Idx - 1)

For Each Obj In MyBase_
Keep = False

If TypeOf Conditions(Idx - 2) Is Field Then
LHS = CallByName(Obj, Conditions(Idx - 2), VbGet)
Else
LHS = UCase$(Conditions(Idx - 2))
End If

If TypeOf Conditions(Idx) Is Field Then
RHS = CallByName(Obj, Conditions(Idx), VbGet)
Else
RHS = Conditions(Idx)
End If

Select Case Op
Case [>=]
Keep = LHS >= RHS

Case [>]
Keep = LHS > RHS

Case [=]
Keep = LHS = RHS

Case [<]
Keep = LHS < RHS

Case [<=]
Keep = LHS <= RHS

Case [<>]
Keep = LHS <> RHS

Case [Like]
Keep = LHS Like RHS

Case [And]
Keep = LHS And RHS

Case [Or]
Keep = LHS Or RHS

Case [In]
For Each Prop In RHS
If Prop = LHS Then Keep = True: Exit For
Next

Case Else
Debug.Assert False
End Select

Jdx = Jdx + 1

If IsFirst Then
Keeps(Jdx) = Keep

ElseIf Connect = [And] Then
Keeps(Jdx) = Keeps(Jdx) And Keep

ElseIf Connect = [Or] Then
Keeps(Jdx) = Keeps(Jdx) Or Keep

Else
Err.Raise 5, "PINQ", "Invalid operator"
End If
Next

IsFirst = False
Jdx = 0
Idx = Idx + 1
If Idx > Udx Then Exit Do
Connect = Conditions(Idx)
Loop

For Idx = MyBase_.Count To 1 Step -1
If Not Keeps(Idx) Then MyBase_.Remove Idx
Next
End If

Set Where = Me
End Property

Public Property Get Contains(ParamArray Conditions() As Variant) As Boolean
Const Msg1 = "Expected: Field name or expression"
Const Msg2 = "Expected: Comparison operator"

Dim Keep As Boolean
Dim IsFirst As Boolean
Dim Idx As Long
Dim Jdx As Long
Dim Udx As Long
Dim Obj As Object
Dim Field As Variant
Dim Value As Variant
Dim Prop As Variant
Dim Op As OperatorNumbers
Dim Connect As OperatorNumbers

If MyBase_.Count = 0 Then Exit Property
IsFirst = True
Idx = -1
Udx = UBound(Conditions)
ReDim Keeps(1 To MyBase_.Count) As Boolean

Do
Idx = Idx + 1
If Idx > Udx Then Err.Raise 5, TypeName(Me), Msg1

Idx = Idx + 1
If Idx > Udx Then Err.Raise 5, TypeName(Me), Msg2

Idx = Idx + 1
If Idx > Udx Then Err.Raise 5, TypeName(Me), Msg1

For Each Obj In MyBase_
If TypeOf Conditions(Idx - 2) Is Field Then
Field = CallByName(Obj, Conditions(Idx - 2), VbGet)
Else
Field = UCase$(Conditions(Idx - 2))
End If

Op = Conditions(Idx - 1)

If TypeOf Conditions(Idx) Is Field Then
Value = CallByName(Obj, Conditions(Idx), VbGet)
Else
Value = Conditions(Idx)
End If

Select Case Op
Case [>=]
Keep = Field >= Value

Case [>]
Keep = Field > Value

Case [=]
Keep = Field = Value

Case [<]
Keep = Field < Value

Case [<=]
Keep = Field <= Value

Case [<>]
Keep = Field <> Value

Case [Like]
Keep = Field Like Value

Case [And]
Keep = Field And Value

Case [Or]
Keep = Field Or Value

Case [In]
For Each Prop In Value
If Field = Prop Then Keep = True: Exit For
Next

Case Else
Debug.Assert False
End Select

Jdx = Jdx + 1

If IsFirst Then
Keeps(Jdx) = Keep

ElseIf Connect = [And] Then
Keeps(Jdx) = Keeps(Jdx) And Keep

ElseIf Connect = [Or] Then
Keeps(Jdx) = Keeps(Jdx) Or Keep

Else
Err.Raise 5, "PINQ", "Invalid operator"
End If
Next

IsFirst = False
Jdx = 0
Idx = Idx + 1
If Idx > Udx Then Exit Do
Connect = Conditions(Idx)
Loop

Contains = True

For Idx = 1 To MyBase_.Count
If Keeps(Idx) Then Exit Property
Next

Contains = False
End Property

Public Property Get OrderBy(ParamArray Fields() As Variant) As PINQ
Dim IsDesc As Boolean
Dim Swap As Boolean
Dim Idx As Long
Dim Length As Long
Dim Udx As Long
Dim Jdx As Long
Dim Field As String
Dim LHS As Variant
Dim RHS As Variant

Udx = UBound(Fields)
Length = MyBase_.Count

Do
Swap = False

For Idx = 2 To Length
Jdx = 0

Do
IsDesc = False
Field = Fields(Jdx)

If Jdx < Udx Then
If Not IsObject(Fields(Jdx + 1)) And Not IsArray(Fields(Jdx + 1)) Then
If Fields(Jdx + 1) = [Desc] Then Jdx = Jdx + 1: IsDesc = True
End If
End If

LHS = CallByName(MyBase_(Idx - 1), Field, VbGet)
RHS = CallByName(MyBase_(Idx), Field, VbGet)
Swap = False

If LHS < RHS Then
Swap = IsDesc
If Not Swap Then Exit Do

ElseIf LHS > RHS Then
Swap = Not IsDesc
If Not Swap Then Exit Do
End If

Jdx = Jdx + 1
Loop Until Jdx >= Udx Or Swap

If Swap Then
MyBase_.Add MyBase_(Idx), Before:=Idx - 1
MyBase_.Remove Idx + 1
Exit For
End If
Next
Loop While Swap

Set OrderBy = Me
End Property

Public Property Get Count() As Long
Count = MyBase_.Count
End Property
End Class


Public Class PrintArg
Option Explicit

Public Indent As PrintIndent
Public Value As IExpression
Public HasSemicolon As Boolean
End Class


Public Class PrintConstruct
Option Explicit
Implements IStmt

Private Output_ As KeyedList

Public FileNumber As IExpression

Private Sub Class_Initialize()
Set Output_ = New KeyedList
Set Output_.T = NewValidator(TypeName(New PrintArg))
End Sub

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snPrint
End Property

Public Property Get Output() As KeyedList
Set Output = Output_
End Property
End Class


Public Class PrintIndent
Option Explicit

Public IsTab As Boolean
Public Value As IExpression
End Class


Public Class PropertyConstruct
Option Explicit
Implements IMethod

Private Kind_ As VbCallType
Private Id_ As Identifier
Private Parms_ As KeyedList
Private Body_ As KeyedList
Private Attributes_ As KeyedList
Private Consts_ As KeyedList

Public Access As Accessibility
Public IsStatic As Boolean
Public IsDefault As Boolean
Public DataType As DataType

Private Sub Class_Initialize()
Set Parms_ = New KeyedList
Set Parms_.T = NewValidator(TypeName(New Parameter))
Parms_.CompareMode = vbTextCompare

Set Body_ = New KeyedList
Set Body_.T = New StmtValidator

Set Attributes_ = New KeyedList
Set Attributes_.T = NewValidator(TypeName(New AttributeConstruct))

Set Consts_ = New KeyedList
Set Consts_.T = NewValidator(TypeName(New ConstConstruct))
End Sub

Public Property Get Parameters() As KeyedList
Set Parameters = Parms_
End Property

Public Property Get Body() As KeyedList
Set Body = Body_
End Property

Public Property Get Attributes() As KeyedList
Set Attributes = Attributes_
End Property

Public Property Get Consts() As KeyedList
Set Consts = Consts_
End Property

Public Property Get Id() As Identifier
Set Id = Id_
End Property

Friend Property Set Id(ByVal Value As Identifier)
Set Id_ = Value
End Property

Public Property Get Kind() As VbCallType
Kind = Kind_
End Property

Friend Property Let Kind(ByVal Value As VbCallType)
Kind_ = Value
End Property

Private Property Get IMethod_Access() As Accessibility
IMethod_Access = Access
End Property

Private Property Get IMethod_Consts() As KeyedList
Set IMethod_Consts = Consts_
End Property

Private Property Get IMethod_DataType() As DataType
Set IMethod_DataType = DataType
End Property

Private Property Get IMethod_Id() As Identifier
Set IMethod_Id = Id_
End Property

Private Property Get IMethod_Kind() As VbCallType
IMethod_Kind = Kind_
End Property

Private Property Get IMethod_Parameters() As KeyedList
Set IMethod_Parameters = Parms_
End Property
End Class


Public Class PropertySlot
Option Explicit

Private PropertyGet_ As PropertyConstruct
Private PropertyLet_ As PropertyConstruct
Private PropertySet_ As PropertyConstruct

Public Id As Identifier

Public Sub Add(ByVal Kind As VbCallType, ByVal Item As PropertyConstruct)
Select Case Kind
Case VbGet
If Not PropertyGet_ Is Nothing Then Err.Raise 457
Set PropertyGet_ = Item

Case VbLet
If Not PropertyLet_ Is Nothing Then Err.Raise 457
Set PropertyLet_ = Item

Case VbSet
If Not PropertySet_ Is Nothing Then Err.Raise 457
Set PropertySet_ = Item

Case Else
Rem It should not happen
Debug.Assert False
End Select

Item.Kind = Kind
Set Item.Id = Id
End Sub

Public Default Property Get Item(ByVal Kind As VbCallType) As PropertyConstruct
Select Case Kind
Case VbGet
Set Item = PropertyGet_

Case VbLet
Set Item = PropertyLet_

Case VbSet
Set Item = PropertySet_

Case Else
Rem It should not happen
Debug.Assert False
End Select
End Property

Public Property Get Exists(ByVal Kind As VbCallType) As Boolean
Select Case Kind
Case VbGet
Exists = Not PropertyGet_ Is Nothing

Case VbLet
Exists = Not PropertyLet_ Is Nothing

Case VbSet
Exists = Not PropertySet_ Is Nothing

Case Else
Rem It should not happen
Debug.Assert False
End Select
End Property

Public Iterator Function NewEnum() As IUnknown
Dim It As KeyedList

Set It = New KeyedList
If Not PropertyGet_ Is Nothing Then It.Add PropertyGet_
If Not PropertyLet_ Is Nothing Then It.Add PropertyLet_
If Not PropertySet_ Is Nothing Then It.Add PropertySet_
Set NewEnum = It.NewEnum
End Function
End Class


Public Class PutConstruct
Option Explicit
Implements IStmt

Public FileNumber As IExpression
Public RecNumber As IExpression
Public Var As Symbol

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snPut
End Property
End Class


Public Class RaiseEventConstruct
Option Explicit
Implements IStmt

Private Arguments_ As KeyedList

Public Id As Identifier

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snRaiseEvent
End Property

Public Property Get Arguments() As KeyedList
Set Arguments = Arguments_
End Property

Friend Property Set Arguments(ByVal Value As KeyedList)
Set Arguments_ = Value
End Property
End Class


Public Class ReDimAdder
Option Explicit
Implements IVarAdder

Private Vars_ As KeyedList
Private Panel_ As ControlPanel

Private Sub IVarAdder_Add(ByVal SourcePath As String, ByVal Var As Variable, ByVal Name As String)
If Panel_.Entity.Vars.Exists(Name) Then Exit Sub

Vars_.Add Var, Name
Panel_.AddVar SourcePath, Var, IsReDim:=True
SymTable.Add Var, Panel_, IsStdLib:=Panel_.Entity.StdLib
End Sub

Private Property Set IVarAdder_Panel(ByVal Value As ControlPanel)
Set Panel_ = Value
End Property

Private Property Get IVarAdder_Panel() As ControlPanel
Set IVarAdder_Panel = Panel_
End Property

Private Property Set IVarAdder_Vars(ByVal Value As KeyedList)
Set Vars_ = Value
End Property

Private Property Get IVarAdder_Vars() As KeyedList
Set IVarAdder_Vars = Vars_
End Property
End Class


Public Class ReDimConstruct
Option Explicit
Implements IStmt

Private Vars_ As KeyedList

Public HasPreserve As Boolean

Private Sub Class_Initialize()
Set Vars_ = New KeyedList
Set Vars_.T = NewValidator(TypeName(New Variable))
End Sub

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snReDim
End Property

Public Property Get Vars() As KeyedList
Set Vars = Vars_
End Property
End Class


Public Class ResetConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snReset
End Property
End Class


Public Class ResumeConstruct
Option Explicit
Implements IStmt

Public IsNext As Boolean
Public Target As IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snResume
End Property
End Class


Public Class ReturnConstruct
Option Explicit
Implements IStmt

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snReturn
End Property
End Class


Public Class Reverter
Option Explicit
Implements IVisitor

Private It_ As IVisitor
Private Withs_ As KeyedList

Public Builder As ITextBuilder

Private Sub Class_Initialize()
Set It_ = Me
Set Withs_ = New KeyedList
Set Withs_.T = New ExprValidator
End Sub

Private Sub IVisitor_VisitAccess(ByVal Access As Accessibility, Optional ByRef Break As Boolean)
Select Case Access
Case acPublic
Builder.Append "Public "

Case acPrivate
Builder.Append "Private "

Case acFriend
Builder.Append "Friend "
End Select
End Sub

Private Sub IVisitor_VisitAttributes(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Attrs As KeyedList, Optional ByRef Break As Boolean)
Dim Attr As AttributeConstruct

For Each Attr In Attrs
Builder.Append "Attribute "
It_.VisitId Attr.Id
Builder.Append "="
It_.VisitExpression Entity, NullMethod, Attr.Value, Withs_
Builder.AppendLn
Next
End Sub

Private Sub IVisitor_VisitBody(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Body As KeyedList, Optional ByRef Break As Boolean)
Dim Stmt As IStmt

For Each Stmt In Body
It_.VisitStmt Entity, Method, Stmt
Builder.AppendLn
Next
End Sub

Private Sub IVisitor_VisitCall(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As CallConstruct, Optional ByRef Break As Boolean)
Dim Count As Integer
Dim Expr As IExpression

It_.VisitExpression Entity, Method, Stmt.LHS, Withs_

If Stmt.Arguments.Count > 0 Then
Builder.Append "("

For Each Expr In Stmt.Arguments
It_.VisitExpression Entity, Method, Expr, Withs_
Count = Count + 1
If Count <> Stmt.Arguments.Count Then Builder.Append ", "
Next

Builder.Append ")"
End If
End Sub

Private Sub IVisitor_VisitClose(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As CloseConstruct, Optional ByRef Break As Boolean)
Dim Number As IExpression

Builder.Append "Close"

For Each Number In Stmt.FileNumbers
Builder.Append " "
It_.VisitExpression Entity, Method, Number, Withs_
Next
End Sub

Private Sub IVisitor_VisitConst(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Cnt As ConstConstruct, Optional ByRef Break As Boolean)
If Cnt.Access = acLocal Then Builder.Deindent

It_.VisitAccess Cnt.Access
Builder.Append "Const "
It_.VisitId Cnt.Id

If Not Cnt.DataType Is Nothing Then
Builder.Append " As "
It_.VisitDataType Entity, NullMethod, Cnt.DataType
End If

If Not Cnt.Value Is Nothing Then
Builder.Append " = "
It_.VisitExpression Entity, NullMethod, Cnt.Value, Withs_
End If

If Cnt.Access = acLocal Then Builder.Indent
End Sub

Private Sub IVisitor_VisitContinue(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ContinueConstruct, Optional ByRef Break As Boolean)
Builder.Append "Continue "

Select Case Stmt.What
Case cwDo
Builder.Append "Do "

Case cwFor
Builder.Append "For "

Case cwWhile
Builder.Append "While "
End Select
End Sub

Private Sub IVisitor_VisitDataType(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal DataType As DataType, Optional ByRef Break As Boolean)
It_.VisitId DataType.Id

If Not DataType.FixedLength Is Nothing Then
Builder.Append " * "
It_.VisitExpression Entity, NullMethod, DataType.FixedLength, Withs_
End If
End Sub

Private Sub IVisitor_VisitDebug(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As DebugConstruct, Optional ByRef Break As Boolean)
End Sub

Private Sub IVisitor_VisitDeclare(ByVal Entity As Entity, ByVal Dcl As DeclareConstruct, Optional ByRef Break As Boolean)
It_.VisitAccess Dcl.Access
Builder.Append "Declare "
#If Win64 Then
Builder.Append "SafePtr "
#End If
Builder.Append IIf(Dcl.IsSub, "Sub ", "Function ")
It_.VisitId Dcl.Id
If Dcl.IsCDecl Then Builder.Append " CDecl"
Builder.Append " Lib "
It_.VisitToken Dcl.LibName
Builder.Append " "

If Not Dcl.AliasName Is Nothing Then
Builder.Append "Alias "
It_.VisitToken Dcl.AliasName
End If

It_.VisitParams Entity, Nothing, Dcl.Parameters

If Not Dcl.IsSub Then
Builder.Append " As "
It_.VisitDataType Entity, Nothing, Dcl.DataType
End If
End Sub

Private Sub IVisitor_VisitDim(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Stmt As Variable, Optional ByRef Break As Boolean)
If Stmt.Access = acLocal Then
Builder.Append "Dim "
Else
It_.VisitAccess Stmt.Access
End If

If Stmt.IsDefault Then Builder.Append "Default "
If Stmt.HasWithEvents Then Builder.Append "WithEvents "
It_.VisitId Stmt.Id
It_.VisitSubscripts Entity, NullMethod, Stmt.Subscripts
Builder.Append " As "
If Stmt.HasNew Then Builder.Append "New "
It_.VisitDataType Entity, NullMethod, Stmt.DataType

If Not Stmt.Init Is Nothing Then
Builder.Append " = "
It_.VisitExpression Entity, NullMethod, Stmt.Init, Withs_
End If
End Sub

Private Sub IVisitor_VisitDo(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As DoConstruct, Optional ByRef Break As Boolean)
Builder.Append "Do"

Select Case Stmt.DoType
Case dtDoWhileLoop
Builder.Append " While "
It_.VisitExpression Entity, Method, Stmt.Condition, Withs_

Case dtDoUntilLoop
Builder.Append " Until "
It_.VisitExpression Entity, Method, Stmt.Condition, Withs_
End Select

Builder.AppendLn
Builder.Indent

It_.VisitBody Entity, Method, Stmt.Body

Builder.Deindent
Builder.Append "Loop"

Select Case Stmt.DoType
Case dtDoLoopWhile
Builder.Append " While "
It_.VisitExpression Entity, Method, Stmt.Condition, Withs_

Case dtDoLoopUntil
Builder.Append " Until "
It_.VisitExpression Entity, Method, Stmt.Condition, Withs_
End Select
End Sub

Private Sub IVisitor_VisitEnd(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As EndConstruct, Optional ByRef Break As Boolean)
Builder.Append "End"
End Sub

Private Sub IVisitor_VisitEntity(ByVal Entity As Entity, Optional ByRef Break As Boolean)
Dim Sep As Boolean
Dim Count As Integer
Dim Def As DefType
Dim Var As Variable
Dim Slt As PropertySlot
Dim Prc As SubConstruct
Dim Udt As TypeConstruct
Dim Enm As EnumConstruct
Dim Evt As EventConstruct
Dim Cnt As ConstConstruct
Dim Dcl As DeclareConstruct
Dim Fnc As FunctionConstruct
Dim Prp As PropertyConstruct
Dim Ipl As ImplementsConstruct

With Builder
It_.VisitAccess Entity.Access
.Append IIf(Entity.IsClass, "Class ", "Module ")
It_.VisitId Entity.Id
.AppendLn
.Indent

If Entity.OptionBase <> 0 Then
.Append "Option Base "
.AppendLn Entity.OptionBase
End If

If Entity.OptionCompare <> vbBinaryCompare Then
.Append "Option Compare "
.AppendLn IIf(Entity.OptionCompare = vbBinaryCompare, "Binary", "Text")
End If

If Entity.OptionExplicit Then .AppendLn "Option Explicit"
.AppendLn
It_.VisitAttributes Entity, Nothing, Entity.Attributes

For Each Ipl In Entity.Impls
It_.VisitImplements Entity, Ipl
.AppendLn
Sep = True
Next

If Sep And Entity.Events.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Evt In Entity.Events
It_.VisitEvent Entity, Evt
.AppendLn
Sep = True
Next

If Sep And Entity.Types.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Udt In Entity.Types
It_.VisitType Entity, Udt
.AppendLn

Count = Count + 1
If Count <> Entity.Types.Count Then .AppendLn
Sep = True
Next

If Sep And Entity.Vars.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Var In Entity.Vars
It_.VisitDim Entity, Nothing, Var
.AppendLn
Sep = True
Next

If Sep And Entity.Consts.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Cnt In Entity.Consts
It_.VisitConst Entity, Nothing, Cnt
.AppendLn
Sep = True
Next

If Sep And Entity.Declares.Count > 0 Then
.AppendLn
Sep = False
End If

For Each Dcl In Entity.Declares
It_.VisitDeclare Entity, Dcl
.AppendLn
Sep = True
Next

If Sep And Entity.Enums.Count > 0 Then
.AppendLn
Sep = False
End If

Count = 0

For Each Enm In Entity.Enums
It_.VisitEnum Entity, Enm
.AppendLn

Count = Count + 1
If Count <> Entity.Enums.Count Then .AppendLn
Sep = True
Next

If Sep And Entity.Functions.Count > 0 Then
.AppendLn
Sep = False
End If

Count = 0

For Each Fnc In Entity.Functions
It_.VisitAccess Fnc.Access
If Fnc.IsStatic Then .Append "Static "
If Fnc.IsDefault Then .Append "Default "
If Fnc.IsIterator Then .Append "Iterator "
.Append "Function "
It_.VisitId Fnc.Id
It_.VisitParams Entity, Fnc, Fnc.Parameters
.Append " As "
It_.VisitDataType Entity, Fnc, Fnc.DataType
.AppendLn
.Indent
It_.VisitAttributes Entity, Fnc, Fnc.Attributes
It_.VisitBody Entity, Fnc, Fnc.Body
.Deindent
.AppendLn "End Function"

Count = Count + 1
If Count <> Entity.Functions.Count Then .AppendLn
Sep = True
Next

If Sep And Entity.Subs.Count > 0 Then
.AppendLn
Sep = False
End If

Count = 0

For Each Prc In Entity.Subs
It_.VisitAccess Prc.Access
If Prc.IsStatic Then .Append "Static "
If Prc.IsDefault Then .Append "Default "
.Append "Sub "
It_.VisitId Prc.Id
It_.VisitParams Entity, Prc, Prc.Parameters
.AppendLn
.Indent
It_.VisitAttributes Entity, Prc, Prc.Attributes
It_.VisitBody Entity, Prc, Prc.Body
.Deindent
.AppendLn "End Sub"
Sep = True
Count = Count + 1
If Count <> Entity.Subs.Count Then .AppendLn
Next

If Sep And Entity.Properties.Count > 0 Then
.AppendLn
Sep = False
End If

Count = 0

For Each Slt In Entity.Properties
If Slt.Exists(VbGet) Then
Set Prp = Slt(VbGet)
It_.VisitAccess Prp.Access
If Prp.IsStatic Then .Append "Static "
If Prp.IsDefault Then .Append "Default "

.Append "Property Get "
It_.VisitId Slt.Id
It_.VisitParams Entity, Prp, Prp.Parameters
.Append " As "
It_.VisitDataType Entity, Prp, Prp.DataType
.AppendLn

.Indent
It_.VisitAttributes Entity, Prp, Prp.Attributes
It_.VisitBody Entity, Prp, Prp.Body
.Deindent
.AppendLn "End Property"

If Slt.Exists(VbLet) Or Slt.Exists(VbSet) Then .AppendLn
End If

If Slt.Exists(VbLet) Then
Set Prp = Slt(VbLet)
It_.VisitAccess Prp.Access
If Prp.IsStatic Then .Append "Static "
If Prp.IsDefault Then .Append "Default "

.Append "Property Let "
It_.VisitId Slt.Id
It_.VisitParams Entity, Prp, Prp.Parameters
.AppendLn

.Indent
It_.VisitBody Entity, Prp, Prp.Body
.Deindent
.AppendLn "End Property"
If Slt.Exists(VbSet) Then .AppendLn
End If

If Slt.Exists(VbSet) Then
Set Prp = Slt(VbSet)
It_.VisitAccess Prp.Access
If Prp.IsStatic Then .Append "Static "
If Prp.IsDefault Then .Append "Default "

.Append "Property Set "
It_.VisitId Slt.Id
It_.VisitParams Entity, Prp, Prp.Parameters
.AppendLn

.Indent
It_.VisitBody Entity, Prp, Prp.Body
.Deindent
.AppendLn "End Property"
End If

Count = Count + 1
If Count <> Entity.Properties.Count Then .AppendLn
Next

.Deindent
.Append "End "
.AppendLn IIf(Entity.IsClass, "Class", "Module")
End With
End Sub

Private Sub IVisitor_VisitEnum(ByVal Entity As Entity, ByVal Enm As EnumConstruct, Optional ByRef Break As Boolean)
Dim Mem As EnumerandConstruct

It_.VisitAccess Enm.Access
Builder.Append "Enum "
It_.VisitId Enm.Id
Builder.AppendLn
Builder.Indent

For Each Mem In Enm.Enumerands
It_.VisitId Mem.Id

If Not Mem.Value Is Nothing Then
Builder.Append " = "
It_.VisitExpression Entity, Nothing, Mem.Value, Withs_
End If

Builder.AppendLn
Next

Builder.Deindent
Builder.Append "End Enum"
End Sub

Private Sub IVisitor_VisitErase(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As EraseConstruct, Optional ByRef Break As Boolean)
Dim Count As Integer
Dim Var As Variable

Builder.Append "Erase "

For Each Var In Stmt.Vars
It_.VisitId Var.Id
Count = Count + 1
If Count <> Stmt.Vars.Count Then Builder.Append ", "
Next

Builder.Append " "
End Sub

Private Sub IVisitor_VisitEvent(ByVal Entity As Entity, ByVal Evt As EventConstruct, Optional ByRef Break As Boolean)
It_.VisitAccess Evt.Access
Builder.Append "Event "
It_.VisitId Evt.Id
It_.VisitParams Entity, Nothing, Evt.Parameters
End Sub

Private Sub IVisitor_VisitExit(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ExitConstruct, Optional ByRef Break As Boolean)
Builder.Append "Exit "

Select Case Stmt.What
Case ewDo
Builder.Append "Do "

Case ewFor
Builder.Append "For "

Case ewWhile
Builder.Append "While "

Case ewSub
Builder.Append "Sub "

Case ewFunction
Builder.Append "Function "

Case ewProperty
Builder.Append "Property "

Case ewSelect
Builder.Append "Select "
End Select
End Sub

Private Sub IVisitor_VisitExpression( _
ByVal Entity As Entity, _
ByVal NullMethod As IMethod, _
ByVal Expr As IExpression, _
ByVal Withs As KeyedList, _
Optional ByVal IsSet As Boolean, _
Optional ByVal IsLHS As Boolean, _
Optional ByVal PrevOp As Operator, _
Optional ByRef Break As Boolean _
)
Static Recurse As Integer
Dim Idx As Integer
Dim Exr As IExpression

Select Case Expr.Kind
Case ekLiteral
Dim Lit As Literal
Set Lit = Expr
It_.VisitToken Lit.Value

Case ekSymbol
Dim Sym As Symbol
Set Sym = Expr
It_.VisitToken Sym.Value

Case ekFileHandle
Dim Hnd As FileHandle
Set Hnd = Expr
Builder.Append "#"
It_.VisitToken Hnd.Value

Case ekTuple
Dim Tup As TupleConstruct
Set Tup = Expr

For Idx = 1 To Tup.Elements.Count
Set Exr = Tup.Elements(Idx)
It_.VisitExpression Entity, NullMethod, Exr, Withs_, IsSet, IsLHS
If Idx <> Tup.Elements.Count Then Builder.Append ", "
Next

Case ekUnaryExpr
Dim Uni As UnaryExpression
Set Uni = Expr
It_.VisitOperator Uni.Operator
Recurse = Recurse + 1
It_.VisitExpression Entity, NullMethod, Uni.Value, Withs_, IsSet, IsLHS
Recurse = Recurse - 1

Case ekBinaryExpr
Dim Bin As BinaryExpression
Set Bin = Expr

Dim Par As Boolean
If Not PrevOp Is Nothing Then Par = ComparePrecedence(PrevOp, Bin.Operator) = 1
If Par Then Builder.Append "("

Recurse = Recurse + 1
It_.VisitExpression Entity, NullMethod, Bin.LHS, Withs_, IsSet:=IsSet, PrevOp:=Bin.Operator
It_.VisitOperator Bin.Operator
It_.VisitExpression Entity, NullMethod, Bin.RHS, Withs_, IsSet:=IsSet, PrevOp:=Bin.Operator
Recurse = Recurse - 1

If Par Then Builder.Append ")"

Case ekIndexer
It_.VisitCall Entity, NullMethod, Expr
End Select
End Sub

Private Sub IVisitor_VisitFor(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ForConstruct, Optional ByRef Break As Boolean)
Dim Lit As Literal
Dim HasStep As Boolean

Builder.Append "For "
It_.VisitToken Stmt.Counter.Value
Builder.Append " = "
It_.VisitExpression Entity, Method, Stmt.StartValue, Withs_
Builder.Append " To "
It_.VisitExpression Entity, Method, Stmt.EndValue, Withs_

If Stmt.Increment.Kind = ekLiteral Then
Set Lit = Stmt.Increment
HasStep = Lit.Value.Line <> 0 Or Lit.Value.Column <> 0
End If

If HasStep Then
Builder.Append " Step "
It_.VisitExpression Entity, Method, Stmt.Increment, Withs_
End If

Builder.AppendLn
Builder.Indent

It_.VisitBody Entity, Method, Stmt.Body

Builder.Deindent
Builder.Append "Next"
End Sub

Private Sub IVisitor_VisitForEach(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ForEachConstruct, Optional ByRef Break As Boolean)
Builder.Append "For Each "
It_.VisitToken Stmt.Element.Value
Builder.Append " In "
It_.VisitExpression Entity, Method, Stmt.Group, Withs_

Builder.AppendLn
Builder.Indent

It_.VisitBody Entity, Method, Stmt.Body

Builder.Deindent
Builder.Append "Next"
End Sub

Private Sub IVisitor_VisitGet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GetConstruct, Optional ByRef Break As Boolean)
Builder.Append "Get "
It_.VisitExpression Entity, Method, Stmt.FileNumber, Withs_
Builder.Append ", "
If Not Stmt.RecNumber Is Nothing Then It_.VisitExpression Entity, Method, Stmt.RecNumber, Withs_
Builder.Append ", "
It_.VisitToken Stmt.Var.Value
End Sub

Private Sub IVisitor_VisitGoSub(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GoSubConstruct, Optional ByRef Break As Boolean)
Dim Label As LabelConstruct
Dim LinNum As LineNumberConstruct

Builder.Append "GoSub "

If Stmt.Target.Kind = snLineNumber Then
Set LinNum = Stmt.Target
It_.VisitToken LinNum.Value
Else
Set Label = Stmt.Target
It_.VisitId Label.Id
End If
End Sub

Private Sub IVisitor_VisitGoTo(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As GoToConstruct, Optional ByRef Break As Boolean)
Dim Label As LabelConstruct
Dim LinNum As LineNumberConstruct

Builder.Append "GoTo "

If Stmt.Target.Kind = snLineNumber Then
Set LinNum = Stmt.Target
It_.VisitToken LinNum.Value
Else
Set Label = Stmt.Target
It_.VisitId Label.Id
End If
End Sub

Private Sub IVisitor_VisitId(ByVal Id As Identifier, Optional ByRef Break As Boolean)
If Not Id.Project Is Nothing Then
It_.VisitToken Id.Project
Builder.Append "."
End If

It_.VisitToken Id.Name
End Sub

Private Sub IVisitor_VisitIf(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As IfConstruct, Optional ByRef Break As Boolean)
Dim Arm As IfArm
Dim SubStmt As IStmt
Dim Idx As Integer

For Idx = 1 To Stmt.Arms.Count
Builder.Append IIf(Idx = 1, "If ", "ElseIf ")
Set Arm = Stmt.Arms(Idx)
It_.VisitExpression Entity, Method, Arm.Condition, Withs_
Builder.AppendLn " Then"

Builder.Indent
It_.VisitBody Entity, Method, Arm.Body
Builder.Deindent
Next

If Stmt.ElseBody.Count > 0 Then
Builder.AppendLn "Else"
Builder.Indent
It_.VisitBody Entity, Method, Stmt.ElseBody
Builder.Deindent
End If

Builder.Append "End If"
End Sub

Private Sub IVisitor_VisitImplements(ByVal Entity As Entity, ByVal Ipl As ImplementsConstruct, Optional ByRef Break As Boolean)
Builder.Append "Implements "
It_.VisitId Ipl.Id
End Sub

Private Sub IVisitor_VisitInput(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As InputConstruct, Optional ByRef Break As Boolean)
Dim Count As Integer
Dim Var As Symbol

Builder.Append "Input "
It_.VisitExpression Entity, Method, Stmt.FileNumber, Withs_
Builder.Append ", "

For Each Var In Stmt.Vars
It_.VisitToken Var.Value
Count = Count + 1
If Count <> Stmt.Vars.Count Then Builder.Append ", "
Next
End Sub

Private Sub IVisitor_VisitLabel(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LabelConstruct, Optional ByRef Break As Boolean)
Builder.Append NameBank(Stmt.Id.Name)
Builder.Append ": "
End Sub

Private Sub IVisitor_VisitLet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LetConstruct, Optional ByRef Break As Boolean)
It_.VisitExpression Entity, Method, Stmt.Name, Withs_, IsLHS:=True
It_.VisitOperator Stmt.Operator
It_.VisitExpression Entity, Method, Stmt.Value, Withs_
End Sub

Private Sub IVisitor_VisitLineNumber(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LineNumberConstruct, Optional ByRef Break As Boolean)
It_.VisitToken Stmt.Value
End Sub

Private Sub IVisitor_VisitLock(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LockConstruct, Optional ByRef Break As Boolean)
Builder.Append "Lock "
It_.VisitExpression Entity, Method, Stmt.FileNumber, Withs_
Builder.Append ", "
It_.VisitExpression Entity, Method, Stmt.RecordRange, Withs_
End Sub

Private Sub IVisitor_VisitLSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As LSetConstruct, Optional ByRef Break As Boolean)
Builder.Append "LSet "
It_.VisitExpression Entity, Method, Stmt.Name, Withs_, IsLHS:=True
Builder.Append " = "
It_.VisitExpression Entity, Method, Stmt.Value, Withs_
End Sub

Private Sub IVisitor_VisitName(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As NameConstruct, Optional ByRef Break As Boolean)
Builder.Append "Name "
It_.VisitExpression Entity, Method, Stmt.OldPathName, Withs_
Builder.Append " As "
It_.VisitExpression Entity, Method, Stmt.NewPathName, Withs_
End Sub

Private Sub IVisitor_VisitOnComputed(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OnComputedConstruct, Optional ByRef Break As Boolean)
Dim Count As Integer
Dim Target As IStmt
Dim Label As LabelConstruct

Builder.Append "On "
It_.VisitExpression Entity, Method, Stmt.Value, Withs_

If Stmt.IsGoTo Then
Builder.Append " GoTo "
Else
Builder.Append " GoSub "
End If

For Each Target In Stmt.Targets
If Target.Kind = snLabel Then
Set Label = Target
It_.VisitId Label.Id
Else
It_.VisitLineNumber Entity, Method, Target
End If

Count = Count + 1
If Count <> Stmt.Targets.Count Then Builder.Append ", "
Next
End Sub

Private Sub IVisitor_VisitOnError(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OnErrorConstruct, Optional ByRef Break As Boolean)
Builder.Append "On Error "

If Stmt.Statement.Kind = snGoTo Then
It_.VisitGoTo Entity, Method, Stmt.Statement

ElseIf Stmt.Statement.Kind = snResume Then
It_.VisitResume Entity, Method, Stmt.Statement
End If
End Sub

Private Sub IVisitor_VisitOpen(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As OpenConstruct, Optional ByRef Break As Boolean)
Builder.Append "Open "
It_.VisitExpression Entity, Method, Stmt.PathName, Withs_
Builder.Append " For "

Select Case Stmt.FileMode
Case fmAppend
Builder.Append "Append"

Case fmBinary
Builder.Append "Binary"

Case fmInput
Builder.Append "Input"

Case fmOutput
Builder.Append "Output"

Case fmRandom
Builder.Append "Random"
End Select

If Stmt.FileAccess <> faNone Then
Builder.Append " Access "

Select Case Stmt.FileAccess
Case faRead
Builder.Append "Read"

Case faReadWrite
Builder.Append "Read Write"

Case faWrite
Builder.Append "Write"
End Select
End If

Select Case Stmt.FileLock
Case flRead
Builder.Append " Read"

Case flReadWrite
Builder.Append " Read Write"

Case flShared
Builder.Append " Shared"

Case flWrite
Builder.Append " Write"
End Select

Builder.Append " As "
It_.VisitExpression Entity, Method, Stmt.FileNumber, Withs_

If Not Stmt.Length Is Nothing Then
Builder.Append " Len="
It_.VisitExpression Entity, Method, Stmt.Length, Withs_
End If
End Sub

Private Sub IVisitor_VisitOperator(ByVal Stmt As Operator, Optional ByRef Break As Boolean)
If Stmt.IsUnary Then
It_.VisitToken Stmt.Value

Select Case Stmt.Value.Code
Case opWithBang, opWithDot, opNeg
Rem OK

Case Else
Builder.Append " "
End Select

Else
Select Case Stmt.Value.Code
Case opDot, opBang, opNamed
It_.VisitToken Stmt.Value

Case Else
Builder.Append " "
It_.VisitToken Stmt.Value
Builder.Append " "
End Select
End If
End Sub

Private Sub IVisitor_VisitParams(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Params As KeyedList, Optional ByRef Break As Boolean)
Dim Idx As Integer
Dim Parm As Parameter

Builder.Append "("

For Idx = 1 To Params.Count
Set Parm = Params(Idx)

If Parm.IsOptional Then
Builder.Append "Optional "

ElseIf Parm.IsParamArray Then
Builder.Append "ParamArray "
End If

If Not Parm.IsParamArray Then
Builder.Append IIf(Parm.IsByVal, "ByVal ", "ByRef ")
End If

It_.VisitId Parm.Id
If Parm.DataType.IsArray Then Builder.Append "()"

Builder.Append " As "
It_.VisitDataType Entity, NullMethod, Parm.DataType

If Not Parm.Init Is Nothing Then
Builder.Append " = "
It_.VisitExpression Entity, NullMethod, Parm.Init, Withs_
End If

If Idx <> Params.Count Then Builder.Append ", "
Next

Builder.Append ")"
End Sub

Private Sub IVisitor_VisitPrint(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As PrintConstruct, Optional ByRef Break As Boolean)
Dim Count As Integer
Dim Arg As PrintArg

Builder.Append "Print "
It_.VisitExpression Entity, Method, Stmt.FileNumber, Withs_
Builder.Append ", "

For Each Arg In Stmt.Output
Count = Count + 1

If Not Arg.Indent Is Nothing Then
Builder.Append IIf(Arg.Indent.IsTab, " Tab", " Spc")

If Not Arg.Indent.Value Is Nothing Then
Builder.Append "("
It_.VisitExpression Entity, Method, Arg.Indent.Value, Withs_
Builder.Append ")"
End If

Builder.Append " "
End If

It_.VisitExpression Entity, Method, Arg.Value, Withs_

If Arg.HasSemicolon Then Builder.Append ";"
If Count <> Stmt.Output.Count Then Builder.Append " "
Next
End Sub

Private Sub IVisitor_VisitPut(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As PutConstruct, Optional ByRef Break As Boolean)
Builder.Append "Put "
It_.VisitExpression Entity, Method, Stmt.FileNumber, Withs_
Builder.Append ", "
If Not Stmt.RecNumber Is Nothing Then It_.VisitExpression Entity, Method, Stmt.RecNumber, Withs_
Builder.Append ", "
It_.VisitToken Stmt.Var.Value
End Sub

Private Sub IVisitor_VisitRaiseEvent(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As RaiseEventConstruct, Optional ByRef Break As Boolean)
Dim Count As Integer
Dim Expr As IExpression

Builder.Append "RaiseEvent "
It_.VisitId Stmt.Id

If Stmt.Arguments.Count > 0 Then
Builder.Append "("

For Each Expr In Stmt.Arguments
It_.VisitExpression Entity, Method, Expr, Withs_
Count = Count + 1
If Count <> Stmt.Arguments.Count Then Builder.Append ", "
Next

Builder.Append ")"
End If

Builder.Append " "
End Sub

Private Sub IVisitor_VisitReDim(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ReDimConstruct, Optional ByRef Break As Boolean)
Dim Count As Integer
Dim Var As Variable

Builder.Append "ReDim "
If Stmt.HasPreserve Then Builder.Append "Preserve "

For Each Var In Stmt.Vars
It_.VisitId Var.Id
It_.VisitSubscripts Entity, Method, Var.Subscripts
Builder.Append " As "
It_.VisitDataType Entity, Method, Var.DataType
Count = Count + 1
If Count <> Stmt.Vars.Count Then Builder.Append ", "
Next
End Sub

Private Sub IVisitor_VisitReset(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ResetConstruct, Optional ByRef Break As Boolean)
Builder.Append "Reset "
End Sub

Private Sub IVisitor_VisitResume(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ResumeConstruct, Optional ByRef Break As Boolean)
Dim Label As LabelConstruct
Dim LinNum As LineNumberConstruct

Builder.Append "Resume"

If Stmt.IsNext Then
Builder.Append " Next "

ElseIf Stmt.Target.Kind = snLabel Then
Builder.Append " "
Set Label = Stmt.Target
It_.VisitId Label.Id
Else
Set LinNum = Stmt.Target

If LinNum.Value.Text <> "+0" Then
Builder.Append " "
It_.VisitToken LinNum.Value
End If
End If
End Sub

Private Sub IVisitor_VisitReturn(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As ReturnConstruct, Optional ByRef Break As Boolean)
Builder.Append "Return "
End Sub

Private Sub IVisitor_VisitRSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As RSetConstruct, Optional ByRef Break As Boolean)
Builder.Append "RSet "
It_.VisitExpression Entity, Method, Stmt.Name, Withs_, IsLHS:=True
Builder.Append " = "
It_.VisitExpression Entity, Method, Stmt.Value, Withs_
End Sub

Private Sub IVisitor_VisitSeek(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SeekConstruct, Optional ByRef Break As Boolean)
Builder.Append "Seek "
It_.VisitExpression Entity, Method, Stmt.FileNumber, Withs_
Builder.Append ", "
It_.VisitExpression Entity, Method, Stmt.Position, Withs_
End Sub

Private Sub IVisitor_VisitSelect(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SelectConstruct, Optional ByRef Break As Boolean)
Dim Count As Integer
Dim Cond As IExpression
Dim Cs As CaseConstruct
Dim Bin As BinaryExpression

Builder.Append "Select Case "
It_.VisitExpression Entity, Method, Stmt.Value, Withs_
Builder.AppendLn
Builder.Indent

For Each Cs In Stmt.Cases
Count = 0
Builder.Append "Case "

For Each Cond In Cs.Conditions
Count = Count + 1

If Cond.Kind = ekBinaryExpr Then
Set Bin = Cond

If Bin.LHS Is Nothing Then
Builder.Append "Is"
It_.VisitOperator Bin.Operator
Set Cond = Bin.RHS
End If
End If

It_.VisitExpression Entity, Method, Cond, Withs_
If Count <> Cs.Conditions.Count Then Builder.Append ", "
Next

Builder.AppendLn
Builder.Indent
It_.VisitBody Entity, Method, Cs.Body
Builder.Deindent
Next

If Stmt.CaseElse.Count > 0 Then
Builder.AppendLn "Case Else"
Builder.Indent
It_.VisitBody Entity, Method, Stmt.CaseElse
Builder.Deindent
End If

Builder.Deindent
Builder.Append "End Select"
End Sub

Private Sub IVisitor_VisitSet(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As SetConstruct, Optional ByRef Break As Boolean)
Builder.Append "Set "
It_.VisitExpression Entity, Method, Stmt.Name, Withs_, IsSet:=True, IsLHS:=True
Builder.Append " = "
It_.VisitExpression Entity, Method, Stmt.Value, Withs_, IsSet:=True
End Sub

Private Sub IVisitor_VisitSource(ByVal Source As SourceFile, Optional ByRef Break As Boolean)
Dim Idx As Integer
Dim Ent As Entity

For Idx = 1 To Source.Entities.Count
Set Ent = Source.Entities(Idx)
It_.VisitEntity Ent
If Idx <> Source.Entities.Count Then Builder.AppendLn
Next
End Sub

Private Sub IVisitor_VisitStmt(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As IStmt, Optional ByRef Break As Boolean)
Select Case Stmt.Kind
Case snCall
Builder.Append "Call "
It_.VisitCall Entity, Method, Stmt

Case snClose
It_.VisitClose Entity, Method, Stmt

Case snConst
It_.VisitConst Entity, Method, Stmt

Case snContinue
It_.VisitContinue Entity, Method, Stmt

Case snDebug
It_.VisitDebug Entity, Method, Stmt

Case snDim
It_.VisitDim Entity, Method, Stmt

Case snDo
It_.VisitDo Entity, Method, Stmt

Case snEnd
It_.VisitEnd Entity, Method, Stmt

Case snErase
It_.VisitErase Entity, Method, Stmt

Case snExit
It_.VisitExit Entity, Method, Stmt

Case snFor
It_.VisitFor Entity, Method, Stmt

Case snForEach
It_.VisitForEach Entity, Method, Stmt

Case snGet
It_.VisitGet Entity, Method, Stmt

Case snGoSub
It_.VisitGoSub Entity, Method, Stmt

Case snGoTo
It_.VisitGoTo Entity, Method, Stmt

Case snIf
It_.VisitIf Entity, Method, Stmt

Case snInput
It_.VisitInput Entity, Method, Stmt

Case snLabel
It_.VisitLabel Entity, Method, Stmt

Case snLet
It_.VisitLet Entity, Method, Stmt

Case snLineNumber
It_.VisitLineNumber Entity, Method, Stmt

Case snLock
It_.VisitLock Entity, Method, Stmt

Case snLSet
It_.VisitLSet Entity, Method, Stmt

Case snName
It_.VisitName Entity, Method, Stmt

Case snOnError
It_.VisitOnError Entity, Method, Stmt

Case snOnComputed
It_.VisitOnComputed Entity, Method, Stmt

Case snOpen
It_.VisitOpen Entity, Method, Stmt

Case snPrint
It_.VisitPrint Entity, Method, Stmt

Case snPut
It_.VisitPut Entity, Method, Stmt

Case snRaiseEvent
It_.VisitRaiseEvent Entity, Method, Stmt

Case snReDim
It_.VisitReDim Entity, Method, Stmt

Case snReset
It_.VisitReset Entity, Method, Stmt

Case snResume
It_.VisitResume Entity, Method, Stmt

Case snReturn
It_.VisitReturn Entity, Method, Stmt

Case snRSet
It_.VisitRSet Entity, Method, Stmt

Case snSeek
It_.VisitSeek Entity, Method, Stmt

Case snSelect
It_.VisitSelect Entity, Method, Stmt

Case snSet
It_.VisitSet Entity, Method, Stmt

Case snStop
It_.VisitStop Entity, Method, Stmt

Case snUnlock
It_.VisitUnlock Entity, Method, Stmt

Case snWhile
It_.VisitWhile Entity, Method, Stmt

Case snWidth
It_.VisitWidth Entity, Method, Stmt

Case snWith
It_.VisitWith Entity, Method, Stmt

Case snWrite
It_.VisitWrite Entity, Method, Stmt
End Select
End Sub

Private Sub IVisitor_VisitStop(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As StopConstruct, Optional ByRef Break As Boolean)
Builder.Append "Stop "
End Sub

Private Sub IVisitor_VisitSubscripts(ByVal Entity As Entity, ByVal NullMethod As IMethod, ByVal Subscripts As KeyedList, Optional ByRef Break As Boolean)
Dim Idx As Integer
Dim Pair As SubscriptPair

If Subscripts.Count = 0 Then Exit Sub

Builder.Append "("

For Idx = 1 To Subscripts.Count
Set Pair = Subscripts(Idx)

It_.VisitExpression Entity, NullMethod, Pair.LowerBound, Withs_
Builder.Append " To "
It_.VisitExpression Entity, NullMethod, Pair.UpperBound, Withs_

If Idx <> Subscripts.Count Then Builder.Append ", "
Next

Builder.Append ")"
End Sub

Private Sub IVisitor_VisitToken(ByVal Stmt As Token, Optional ByRef Break As Boolean)
Select Case Stmt.Kind
Case tkBinaryNumber
If Left$(Stmt.Text, 1) = "-" Then Builder.Append "-"
Builder.Append "&B"
Builder.Append Mid$(Stmt.Text, 2)

Case tkDateTime
Builder.Append "#"
Builder.Append Stmt.Text
Builder.Append "#"

Case tkEscapedIdentifier, tkCrazyIdentifier
Builder.Append "["
Builder.Append NameBank(Stmt)
Builder.Append "]"

Case tkFileHandle, tkFloatNumber, tkIntegerNumber, tkSciNumber
If Left$(Stmt.Text, 1) = "+" Then
Builder.Append Mid$(Stmt.Text, 2)
Else
Builder.Append Stmt.Text
End If

Case tkHexaNumber
If Left$(Stmt.Text, 1) = "-" Then Builder.Append "-"
Builder.Append "&H"
Builder.Append Mid$(Stmt.Text, 2)

Case tkIdentifier, tkKeyword
Builder.Append NameBank(Stmt)

Case tkOperator
Builder.Append Replace(NameBank(Stmt), "~", "")

Case tkOctalNumber
If Left$(Stmt.Text, 1) = "-" Then Builder.Append "-"
Builder.Append "&O"
Builder.Append Mid$(Stmt.Text, 2)

Case tkString
Builder.Append """"
Builder.Append Replace(Stmt.Text, """", """""""")
Builder.Append """"

Case Else
Debug.Assert False
Err.Raise 5, "Reverter.VisitToken"
End Select

If Stmt.Suffix <> vbNullChar Then Builder.Append Stmt.Suffix
End Sub

Private Sub IVisitor_VisitType(ByVal Entity As Entity, ByVal Udt As TypeConstruct, Optional ByRef Break As Boolean)
Dim Mem As Variable

It_.VisitAccess Udt.Access
Builder.Append "Type "
It_.VisitId Udt.Id
Builder.AppendLn
Builder.Indent

For Each Mem In Udt.Members
It_.VisitId Mem.Id
Builder.Append " As "
It_.VisitDataType Entity, Nothing, Mem.DataType

If Mem.DataType.IsArray And Mem.Subscripts.Count = 0 Then
Builder.Append "()"
Else
It_.VisitSubscripts Entity, Nothing, Mem.Subscripts
End If

Builder.AppendLn
Next

Builder.Deindent
Builder.Append "End Type"
End Sub

Private Sub IVisitor_VisitUnlock(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As UnlockConstruct, Optional ByRef Break As Boolean)
Builder.Append "Unlock "
It_.VisitExpression Entity, Method, Stmt.FileNumber, Withs_
Builder.Append ", "
It_.VisitExpression Entity, Method, Stmt.RecordRange, Withs_
End Sub

Private Sub IVisitor_VisitWhile(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WhileConstruct, Optional ByRef Break As Boolean)
Builder.Append "While "
It_.VisitExpression Entity, Method, Stmt.Condition, Withs_

Builder.AppendLn
Builder.Indent

It_.VisitBody Entity, Method, Stmt.Body

Builder.Deindent
Builder.Append "Wend"
End Sub

Private Sub IVisitor_VisitWidth(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WidthConstruct, Optional ByRef Break As Boolean)
Builder.Append "Width "
It_.VisitExpression Entity, Method, Stmt.FileNumber, Withs_
Builder.Append ", "
It_.VisitExpression Entity, Method, Stmt.Value, Withs_
End Sub

Private Sub IVisitor_VisitWith(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WithConstruct, Optional ByRef Break As Boolean)
Builder.Append "With "
It_.VisitExpression Entity, Method, Stmt.PinObject, Withs_
Withs_.Add Stmt.PinObject
Builder.AppendLn

Builder.Indent
It_.VisitBody Entity, Method, Stmt.Body
Builder.Deindent

Withs_.Remove Withs_.Count
Builder.Append "End With"
End Sub

Private Sub IVisitor_VisitWrite(ByVal Entity As Entity, ByVal Method As IMethod, ByVal Stmt As WriteConstruct, Optional ByRef Break As Boolean)
Dim Count As Integer
Dim Expr As IExpression

Builder.Append "Write "
It_.VisitExpression Entity, Method, Stmt.FileNumber, Withs_
Builder.Append ", "

For Each Expr In Stmt.Output
It_.VisitExpression Entity, Method, Expr, Withs_
Count = Count + 1
If Count <> Stmt.Output.Count Then Builder.Append ", "
Next
End Sub
End Class


Public Class RSetConstruct
Option Explicit
Implements IStmt

Public Name As IExpression
Public Value As IExpression

Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snRSet
End Property
End Class


Public Class Scanner
Option Explicit

Private Const Msg_ = "Invalid literal"

Private Const LF_ As Integer = 10 'Line feed
Private Const CR_ As Integer = 13 'Carriage return
Private Const SP_ As Integer = 32 'Space
Private Const US_ As Integer = 95 'Underscore
Private Const BS_ As Integer = 8 'Backspace. Used for line continuation
Private Const ZERO_ As Integer = 48
Private Const NINE_ As Integer = 57
Private Const CRLF_ As Long = &HA000D

Private File_ As Integer
Private RunningLine_ As Long
Private RunningColumn_ As Long
Private FrozenColumn_ As Long
Private PreviousColumn_ As Long
Private FilePath_ As String

Public Enum KeywordNumbers
kwAny = 1
kwAs ' 2
kwAttribute ' 3
kwBoolean ' 4
kwByRef ' 5
kwByte ' 6
kwByVal ' 7
kwCall ' 8
kwCase ' 9
kwCDecl ' 10
kwCircle ' 11
kwClass ' 12
kwClose ' 13
kwConst ' 14
kwContinue ' 15
kwCurrency ' 16
kwDate ' 17
kwDeclare ' 18
kwDefault ' 19
kwDefBool ' 20
kwDefByte ' 21
kwDefCur ' 22
kwDefDate ' 23
kwDefDbl ' 24
kwDefDec ' 25
kwDefInt ' 26
kwDefLng ' 27
kwDefLngLng ' 28
kwDefLngPtr ' 29
kwDefObj ' 30
kwDefSng ' 31
kwDefStr ' 32
kwDefVar ' 33
kwDim ' 34
kwDo ' 35
kwDouble ' 36
kwEach ' 37
kwElse ' 38
kwElseIf ' 39
kwEmpty ' 40
kwEnd ' 41
kwEndIf ' 42
kwEnum ' 43
kwErase ' 44
kwEvent ' 45
kwExit ' 46
kwFalse ' 47
kwFor ' 48
kwFriend ' 49
kwFunction ' 50
kwGet ' 51
kwGlobal ' 52
kwGoSub ' 53
kwGoTo ' 54
kwIf ' 55
kwImplements ' 56
kwIn ' 57
kwInput ' 58
kwInteger ' 59
kwIterator ' 60
kwLet ' 61
kwLocal ' 62
kwLong ' 63
kwLongLong ' 64
kwLongPtr ' 65
kwLoop ' 66
kwLSet ' 67
kwMe ' 68
kwModule ' 69
kwNext ' 70
kwNothing ' 71
kwNull ' 72
kwOn ' 73
kwOpen ' 74
kwOption ' 75
kwOptional ' 76
kwParamArray ' 77
kwPreserve ' 78
kwPrint ' 79
kwPrivate ' 80
kwPSet ' 81
kwPublic ' 83
kwPut ' 84
kwRaiseEvent ' 85
kwReDim ' 86
kwRem ' 87
kwResume ' 88
kwReturn ' 89
kwRSet ' 90
kwScale ' 91
kwSeek ' 92
kwSelect ' 93
kwSet ' 94
kwSingle ' 95
kwStatic ' 96
kwStop ' 97
kwString ' 98
kwSub ' 99
kwThen '100
kwTo '101
kwTrue '102
kwType '103
kwUnlock '104
kwUntil '105
kwVariant '106
kwVoid '107
kwWend '108
kwWhile '109
kwWith '110
kwWithEvents '111
kwWrite '112
End Enum

Public Enum ContextualNumbers
cxAccess = kwWrite + 1 '113
cxAlias ' 2 / 114
cxAppend ' 3 / 115
cxBase ' 4 / 116
cxBinary ' 5 / 117
cxCompare ' 6 / 118
cxDecimal ' 7 / 119
cxError ' 8 / 120
cxExplicit ' 9 / 121
cxLen '10 / 122
cxLib '11 / 123
cxLine '12 / 124
cxLock '13 / 125
cxName '14 / 126
cxObject '15 / 127
cxOutput '16 / 128
cxProperty '17 / 129
cxPtrSafe '18 / 130
cxRandom '19 / 131
cxRead '20 / 132
cxReset '21 / 133
cxShared '22 / 134
cxSpc '23 / 135
cxStep '24 / 136
cxTab '25 / 137
cxText '26 / 138
cxWidth '27 / 139
End Enum

Public Enum OperatorNumbers
opAddressOf = 1
opAndAlso ' 2
opByVal ' 3
opIs ' 4
opIsNot ' 5
opLike ' 6
opNew ' 7
opNot ' 8
opOrElse ' 9
opTo '10
opTypeOf '11
opIdentity '12 (~+)
opNeg '13 (~-)
opLt '14 (<)
opLe '15 (<=)
opEq '16 (=)
opGe '17 (>=)
opGt '18 (>)
opNe '19 (<>)
opNamed '20 (:=)
opWithDot '21 (~.)
opWithBang '22 (~!)
opDot '23 (.)
opBang '24 (!)
opAnd '25
opEqv '26
opImp '27
opMod '28
opOr '29
opXor '30
opSum '31 (+)
opSubt '32 (-)
opMul '33 (*)
opDiv '34 (/)
opIntDiv '35 (\)
opPow '36 (^)
opLSh '37 (<<)
opRSh '38 (>>)
opURSh '39 (>>>)
opConcat '40 (&)
opCompAnd '41 (And=)
opCompEqv '42 (Eqv=)
opCompImp '43 (Imp=)
opCompMod '44 (Mod=)
opCompOr '45 (Or=)
opCompXor '46 (Xor=)
opCompSum '47 (+=)
opCompSubt '48 (-=)
opCompMul '49 (*=)
opCompDiv '50 (/=)
opCompIntDiv '51 (\=)
opCompPow '52 (^=)
opCompLSh '53 (<<=)
opCompRSh '54 (>>=)
opCompURSh '55 (>>>=)
opCompConcat '56 (&=)
opApply '57 ()
End Enum

Private Sub Class_Initialize()
RunningLine_ = 1
RunningColumn_ = 1
End Sub

Private Function AtEnd() As Boolean
AtEnd = Seek(File_) > LOF(File_)
End Function

Public Sub OpenFile(ByVal FilePath As String)
Dim Cp As Integer

FilePath_ = FilePath
If Dir(FilePath) = "" Then Err.Raise 53
File_ = FreeFile
Open FilePath For Binary Access Read As #File_

Rem If the error below happens, we'll let a new-ly created zero-length file behind.
If LOF(File_) = 0 Then Err.Raise 53

Cp = GetCodePoint
If Cp <> &HFEFF Then UngetChar ChrW$(Cp)
End Sub

Public Function GetToken(Optional ByVal ReturnInlineComment As Boolean) As Token
Dim Done As Boolean
Dim Cp As Integer
Dim Ch As String * 1
Dim Token As Token

If AtEnd Then
Set GetToken = NewToken(tkEndOfStream)
Exit Function
End If

Do
Done = True
FrozenColumn_ = RunningColumn_
Cp = GetCodePoint
Ch = ToChar(Cp)

Select Case Ch
Case "["
Set Token = ReadEscapedIdentifier

Case """"
Set Token = ReadString

Case "&"
Set Token = ReadAmpersand

Case "#"
Set Token = ReadHash

Case "0" To "9"
Set Token = ReadNumber(Ch)
Debug.Assert Token.Text <> ""

Rem Removing leading zeros in excess
Do While Left$(Token.Text, 1) = "0"
Token.Text = Mid$(Token.Text, 2)
Loop

Select Case Left$(Token.Text, 1)
Case "", "."
Token.Text = "0" & Token.Text
End Select

If Token.Code = 0 Then
Select Case Token.Kind
Case tkIntegerNumber
Select Case Right$(String$(18, "0") & Token.Text, 19)
Case Is <= "0000000000000032767"
Token.Code = vbInteger

Case Is <= "0000000002147483647"
Token.Code = vbLong

Case Is <= "9223372036854775807"
Token.Code = vbLongLong

Case Else
Token.Code = vbDouble
End Select

Case tkBinaryNumber
Select Case Len(Token.Text)
Case Is > 64
Token.Code = vbDouble

Case Is > 32
Token.Code = vbLongLong

Case Is > 16
Token.Code = vbLong

Case Else
Token.Code = vbInteger
End Select

Case tkOctalNumber
Select Case Right$(String(21, "0") & Token.Text, 19)
Case Is <= "000000000000000077777"
Token.Code = vbInteger

Case Is <= "000000000017777777777"
Token.Code = vbLong

Case Is <= "177777777777777777777"
Token.Code = vbLongLong

Case Else
Token.Code = vbDouble
End Select

Case tkHexaNumber
Select Case Len(Token.Text)
Case Is > 16
Token.Code = vbDouble

Case Is > 8
Token.Code = vbLongLong

Case Is > 4
Token.Code = vbLong

Case Else
Token.Code = vbInteger
End Select

Case tkFloatNumber, tkSciNumber
Token.Code = vbDouble

Case Else
Rem It should not happen
Debug.Assert False
End Select
End If

Token.Text = "+" & Token.Text

Case "+"
Set Token = NewToken(tkOperator, opSum)

Case "-"
Set Token = NewToken(tkOperator, opSubt)

Case "*"
Set Token = NewToken(tkOperator, opMul)

Case "/"
Set Token = NewToken(tkOperator, opDiv)

Case "\"
Set Token = NewToken(tkOperator, opIntDiv)

Case "^"
Set Token = NewToken(tkOperator, opPow)

Case "="
Set Token = NewToken(tkOperator, opEq)

Case "."
Set Token = NewToken(tkOperator, opDot)

Case "!"
Set Token = NewToken(tkOperator, opBang)

Case "<"
Set Token = NewToken(tkOperator, opLt)

If Not AtEnd Then
Ch = GetChar

Select Case Ch
Case ">"
Token.Code = opNe

Case "="
Token.Code = opLe

Case "<"
Token.Code = opLSh

Case Else
UngetChar Ch
End Select
End If

Case ">"
Set Token = NewToken(tkOperator, opGt)

If Not AtEnd Then
Ch = GetChar

Select Case Ch
Case "="
Token.Code = opGe

Case ">"
Token.Code = opRSh

If Not AtEnd Then
Ch = GetChar

If Ch = ">" Then
Token.Code = opURSh
Else
UngetChar Ch
End If
End If

Case Else
UngetChar Ch
End Select
End If

Case ":"
Set Token = NewToken(tkSoftLineBreak)

If Not AtEnd Then
Ch = GetChar

If Ch = "=" Then
Token.Kind = tkOperator
Token.Code = opNamed
Else
UngetChar Ch
End If
End If

Case vbLf
Set Token = NewToken(tkHardLineBreak)

Case "'"
Set Token = ReadComment

Case ","
Set Token = NewToken(tkListSeparator)

Case ";"
Set Token = NewToken(tkPrintSeparator)

Case "("
Set Token = NewToken(tkLeftParenthesis)

Case ")"
Set Token = NewToken(tkRightParenthesis)

Case " "
Set Token = NewToken(tkWhiteSpace)

Case vbBack
Set Token = NewToken(tkLineContinuation)

Case "`"
Set Token = ReadInlineComment

If Not ReturnInlineComment Then
Done = False
Set Token = New Token
End If

Case Else
If Not IsLetter(Cp) Then Fail "Invalid token: '" & Ch & "'"

Set Token = ReadIdentifier(Cp)

If Token.Kind = tkKeyword Then
If Token.Code = kwRem Then Set Token = ReadComment(IsRem:=True)

ElseIf Token.Kind = tkOperator Then
If Not AtEnd Then
Ch = GetChar

If Ch = "=" Then
Select Case Token.Code
Case opAnd, opEqv, opImp, opMod, opOr, opXor
Token.Code = Token.Code + opCompAnd - opAnd

Case Else
UngetChar Ch
End Select
Else
UngetChar Ch
End If
End If
End If
End Select

Select Case Token.Code
Case opSum, opSubt, opMul, opDiv, opIntDiv, opPow
If Not AtEnd Then
Ch = GetChar

If Ch = "=" Then
Token.Code = Token.Code + opCompSum - opSum
Else
UngetChar Ch
End If
End If
End Select
Loop Until Done

Set GetToken = Token
End Function

Private Function GetCodePoint() As Integer
Dim CheckLF As Boolean
Dim Cp1 As Integer
Dim Cp2 As Integer
Dim Cp3 As Integer

Cp1 = NextCodePoint
If IsSpace(Cp1) Then Cp1 = SP_

Select Case Cp1
Case SP_
Cp2 = NextCodePoint

If Cp2 = US_ Then
Cp3 = NextCodePoint

Select Case Cp3
Case CR_
CheckLF = True
AdvanceLine
Cp1 = BS_

Case LF_
AdvanceLine
Cp1 = BS_

Case Else
UngetChar ChrW$(Cp3)
UngetChar ChrW$(Cp2)
End Select
Else
UngetChar ChrW$(Cp2)
End If

Case CR_
CheckLF = True
Cp1 = LF_
End Select

If CheckLF Then
Cp2 = NextCodePoint
If Cp2 <> LF_ Then UngetChar ChrW$(Cp2)
End If

If Cp1 = LF_ Then AdvanceLine
GetCodePoint = Cp1
End Function

Private Function NextCodePoint() As Integer
Dim Result As Integer

Get #File_, , Result
RunningColumn_ = RunningColumn_ + 1
NextCodePoint = Result
End Function

Private Function GetChar() As String
Dim Cp As Integer

Cp = GetCodePoint
GetChar = ToChar(Cp)
End Function

Private Function ToChar(ByVal CodePoint As Integer) As String
Dim Bytes(0 To 1) As Byte

Bytes(0) = CodePoint And &HFF
Bytes(1) = ((CodePoint And &HFF00) \ &H100) And &HFF
ToChar = Bytes
End Function

Private Sub AdvanceLine()
RunningLine_ = RunningLine_ + 1
PreviousColumn_ = RunningColumn_
RunningColumn_ = 1
End Sub

Private Sub UngetChar(ByVal Character As String)
Dim Pos As Long
Dim Length As Long

Length = SizeOf(kwInteger)
If Character = vbBack Then Length = Length * 2 + Len(vbNewLine) * SizeOf(kwInteger)
Pos = Seek(File_)
Seek #File_, Pos - Length

Select Case Character
Case vbLf, vbBack
RunningLine_ = RunningLine_ - 1
RunningColumn_ = PreviousColumn_
End Select

RunningColumn_ = RunningColumn_ - IIf(Character = vbBack, 2, 1)
End Sub

Private Sub Fail(ByVal Msg As String)
Err.Raise vbObjectError + 13, "Scanner", FilePath_ & "(" & RunningLine_ & ", " & FrozenColumn_ & ") " & Msg
End Sub

Private Function ReadIdentifier(ByVal CodePoint As Integer)
Const MAX_LENGTH = 255

Dim IsOK As Boolean
Dim Cp As Integer
Dim Count As Integer
Dim Index As Long
Dim Name As String
Dim Ch As String * 1
Dim Suffix As String * 1
Dim Buffer As String * MAX_LENGTH
Dim Result As Token

Count = 1
Mid$(Buffer, Count, 1) = ChrW(CodePoint)

Do Until AtEnd
Cp = GetCodePoint
Ch = ToChar(Cp)

IsOK = Ch = "_"
If Not IsOK Then IsOK = Ch >= "0" And Ch <= "9"
If Not IsOK Then IsOK = IsLetter(Cp)
If Not IsOK Then IsOK = IsSurrogate(Cp)
If Not IsOK Then Exit Do

Count = Count + 1
If Count > MAX_LENGTH Then Fail "Identifier too long"
Mid$(Buffer, Count, 1) = Ch
Loop

Select Case Ch
Case "!"
Suffix = Ch
Cp = GetCodePoint
Ch = ToChar(Cp)

Rem A!B scenario
If IsLetter(Cp) Then
UngetChar Ch
UngetChar "!"
Suffix = vbNullChar
Else
UngetChar Ch
End If

Case "%", "&", "^", "@", "#", "$"
Suffix = Ch

Case Else
UngetChar Ch
End Select

Set Result = NewToken(tkIdentifier, Suffix:=Suffix)
Name = Left$(Buffer, Count)
Index = NameBank.Keywords.IndexOf(Name)

If Index <> 0 Then
Result.Kind = tkKeyword
Else
Index = NameBank.Operators.IndexOf(Name)

If Index <> 0 Then
Result.Kind = tkOperator
Else
Index = NameBank.Contextuals.IndexOf(Name)

If Index <> 0 Then
Index = NameBank.ToCtxIndex(Index)
Else
Index = NameBank.Ids.IndexOf(Name)

If Index = 0 Then
NameBank.Ids.Add Name, Name
Index = NameBank.Ids.Count
End If

Index = NameBank.ToIdIndex(Index)
End If
End If
End If

Select Case Result.Kind
Case tkKeyword, tkOperator
If Result.Suffix <> vbNullChar Then
If Index = kwString And Result.Suffix = "$" Then
Result.Kind = tkIdentifier
Index = NameBank.ToIdIndex(NameBank.Ids.IndexOf(v.String))

ElseIf Index = kwDate And Result.Suffix = "$" Then
Result.Kind = tkIdentifier
Index = NameBank.ToIdIndex(NameBank.Ids.IndexOf(v.Date))

Else
Fail "Keyword or operator cannot have type-declaration character"
End If
End If
End Select

Result.Code = Index
Set ReadIdentifier = Result
End Function

Private Function ReadEscapedIdentifier() As Token
Const MAX_LENGTH = 255

Dim Cp As Integer
Dim Count As Integer
Dim Name As String
Dim Suffix As String * 1
Dim Buffer As String * MAX_LENGTH
Dim Token As Token
Dim Result As TokenKind

Result = tkEscapedIdentifier

Do Until AtEnd
Cp = GetCodePoint

Select Case Cp
Case US_, ZERO_ To NINE_
Rem OK

Case AscW("]")
Exit Do

Case LF_
Fail "Invalid identifier"

Case Else
If Not IsLetter(Cp) Then If Not IsSurrogate(Cp) Then Result = tkCrazyIdentifier
End Select

Count = Count + 1
If Count > MAX_LENGTH Then Fail "Identifier too long"
Mid$(Buffer, Count, 1) = ToChar(Cp)
Loop

If Not AtEnd Then
Suffix = GetChar

Select Case Suffix
Case "%", "&", "^", "@", "!", "#", "$"
Rem OK

Case Else
UngetChar Suffix
Suffix = vbNullChar
End Select
End If

Set Token = NewToken(Result, Suffix:=Suffix)
Name = Left$(Buffer, Count)
Token.Code = NameBank.Ids.IndexOf(Name)

If Token.Code = 0 Then
NameBank.Ids.Add Name, Name
Token.Code = NameBank.Ids.Count
End If

Token.Code = NameBank.ToIdIndex(Token.Code)
Set ReadEscapedIdentifier = Token
End Function

Private Function ReadString() As Token
Const MAX_LENGTH = 1013

Dim Count As Integer
Dim Ch As String * 1
Dim Buffer As String * MAX_LENGTH

Do
If Count > MAX_LENGTH Then Fail "String too long"

If AtEnd Then
Ch = vbLf
Else
Ch = GetChar
End If

Select Case Ch
Case """"
If AtEnd Then Exit Do
Ch = GetChar

If Ch = """" Then
Count = Append(Count, Buffer, Ch)
Else
Rem We read too much. Let's put it "back".
UngetChar Ch
Exit Do
End If

Case vbLf
Fail "Unclosed string"

Case Else
Count = Append(Count, Buffer, Ch)
End Select
Loop

Set ReadString = NewToken(tkString, , Left$(Buffer, Count))
End Function

Private Function Append(ByVal Count As Integer, ByRef Buffer As String, ByVal Ch As String) As Integer
Count = Count + 1
Mid$(Buffer, Count, 1) = Ch
Append = Count
End Function

Private Function ReadInteger(Optional ByVal FirstDigit As String) As Token
Const MAX_LENGTH = 29

Dim Cp As Integer
Dim Count As Integer
Dim Ch As String * 1
Dim Suffix As String * 1
Dim Buffer As String * MAX_LENGTH

If FirstDigit >= "0" And FirstDigit <= "9" Then
Count = 1
Mid$(Buffer, Count, 1) = FirstDigit
End If

Do Until AtEnd
If Count > MAX_LENGTH Then Fail "Literal too long"
Cp = GetCodePoint
Ch = ToChar(Cp)

Select Case Ch
Case "0" To "9"
Count = Count + 1
Mid$(Buffer, Count, 1) = Ch

Case "%", "&", "^", "@", "!", "#"
Suffix = Ch
Exit Do

Case "_"
Rem We'll ignore it

Case Else
UngetChar Ch
Exit Do
End Select
Loop

Set ReadInteger = NewToken(tkIntegerNumber, , Left$(Buffer, Count), Suffix)
End Function

Private Function ReadFloat(ByVal FirstDigit As String) As Token
Dim Ch As String * 1
Dim Result As Token
Dim FracPart As Token

Set Result = ReadInteger(FirstDigit:=FirstDigit)

If Result.Suffix = vbNullChar Then
If Not AtEnd Then
Ch = GetChar

If Ch = "." Then
Set FracPart = ReadInteger
If FracPart.Text = "" Then Fail "Invalid literal"
Result.Text = Result.Text & "." & FracPart.Text
Result.Kind = tkFloatNumber
Result.Suffix = FracPart.Suffix
Else
UngetChar Ch
End If
End If
End If

Set ReadFloat = Result
End Function

Private Function ReadNumber(ByVal FirstDigit As String) As Token
Dim Ch As String * 1
Dim Sg As String * 1
Dim Result As Token
Dim ExpPart As To