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

Let's build a transpiler! Part 47

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

A word about VB's attributes

VB6 has attributes that are applied to classes, modules, and even variables, but developers have limited access to them through property sheets.
One can see them directly by opening a .CLS, .BAS, .CTL, or .FRM file in Notepad, for instance.
As I said before, I do not intend to support any of them. Some are even made nil by supporting the Iterator and Default keywords.
Others can be easily mimicked, like VB_PredeclaredId.
When VB_PredeclaredId is True, VB provides a read-only default instance having the same name as the class.
An example might help:

Suppose we have an Astronaut class with VB_PredeclaredId True.
VB would give us something functionally equivalent to:

Private Module ImHidden
Private Astronaut_ As New Astronaut

Public Property Get Astronaut() As Astronaut
Set Astronaut = Astronaut_
End Property
End Module

With that, you can invoke any Astronaut's method like this:

Astronaut.FireLaser

Of course, you keep your ability to create as many Astronauts instances as needed.

But there is at least one attribute that provides functionality that cannot be easily replicated: VB_GlobalNameSpace.
When it is True, VB will create a nameless hidden instance of the class and its methods can be invoked from anywhere.

It's almost like code as the one below was possible:

With New Astronaut
Module Program
Sub Main
FireLaser
End Sub
End Module

Class Alien
Sub Class_Initialize()
FireLaser
End Sub
End Class

(...)
End With

It would be handy to use it in our Shifter class.
Being "omnipresent" would allow us to use its methods - LSh, RSh, etc. - like regular functions, not needing to expose them through the Shifts module.
Due to that, I plan to support a new keyword, Omni, that can be applied to classes. Our Shifter class would be declared like this:

Public Omni Class Shifter
(...)
End Class

Back to business

Last time I said I would start transpiling VB to some other programming language.
For a time I thought seriously about using Pascal. It has a free IDE and even supports natively some VB features, like reference-counted memory management and the Currency data type.
But I ended up returning to my "default" of using C. Let's see how it goes

So, I happily started coding, but then some of my shortcomings were thrown to my face.
The first one to raise its ugly head was not inferring some Const's data types.
After trying some things, I decided to create a new class - ConstDataType - that would implement DataType's interface.
That allows us to keep it along with the real DataType objects, while also postponing resolving its data type until all tokens have been read.

I did that because I misunderstood how solving something like Const A = B & C would need to be done.
My reasoning was "B can be in another module that we did not read yet, so I would not be able to resolve it right away."
But after the code was ready, I tested my assumption above and found out that that reasoning was wrong. But, at that time, it was too late, sooo... whatever.

Second, the way I was searching for identifiers in SymTable was not working as I intended.
I substituted it for a different symbol table, SymTab. I hope it gives better results, but as I did not test it thoroughly, that promise remains to be seen.

Another thing is that there was no way to "jump" from the old symbol table to the object registered there, or back.
So, in my redesigned SymTab there's now an Obj field there, storing the represented object, and that object has now an EntryIndex property pointing back to the SymTab's entry.

Third: I fixed my object hierarchy. It (wrongly) started with a SourceFile object, but now it starts with a Project one, as it should.
A Project has a name, a build path, and source files. Source files have classes and/or modules, and they - classes and modules - have everything else (Options, Def<type>s, methods, etc.)

Fourth: Instead of passing around Entity and IMethod, I've moved them from Panel to a new class - Pad - along with Project and the current SourceFile, and am passing that Pad around.
It is used to keep track of symbol's context, like "Is it inside a method?", "What's its Class or Module host?", and other questions like that.

Other small changes

I've said before that I've removed some Debug support. Now, I removed all of it. For now, I'm good with that.
Maybe I'll change my mind later.

While reading this post, I had an idea on how to improve KeyedList, so I changed both KeyedList and KLEnumerator a bit.

Comparisons done in Select Cases that should be case-insensitive were moved to a new module, InsensitiveMethods.

Evaluator was renamed to CompilerStuff. Not the best name, I know...

And before discussing the transpiler code, I need to report some losses.

Defeats

IVisitor was not flexible enough to my needs, so it is gone now, as were ExprChecker, Reverter, and PrettyPrint.
Temporarily I'm not able to convert our object graph back to VB, or HTML. I'll need to re-implement at least the latter sometime in the future.

Can we start transpiling now, please?

Yes, sure. Let's start with VB's built-in data types and its C counterparts:

VB C Comment
Boolean typedef int16_t _VB_BOOLEAN; Boolean is a specialized Integer
Byte uint8_t
Integer int16_t
Long int32_t
LongPtr uintptr_t
LongLong int64_t
Currency typedef int64_t _VB_CURRENCY; Currency is a specialized LongLong
Decimal typedef struct _VB_DECIMAL {
    int16_t TypeDescriptor;
    uint8_t Scale;
    uint8_t Sign;
    int32_t High;
    int32_t Low;
    int32_t Middle;
} _VB_DECIMAL;
Single float
Double double
Date typedef double _VB_DATE; Date is a specialized Double
String typedef wchar_t* _VB_STRING; See below
Object Not defined yet
Variant typedef struct _VB_VARIANT {
    int16_t TypeDescriptor;

    union {
        _VB_BOOLEAN tBool;
        uint8_t tByte;
        int16_t tInt;
        uint16_t tErr;
        int32_t tLng;
        int64_t tLngLng;
        _VB_CURRENCY tCur;
        _VB_DECIMAL tDec;
        float tSng;
        double tDbl;
        _VB_DATE tDtm;
        _VB_STRING tStr;
        IUnknown* tObj;
        _VB_BOOLEAN* pBool;
        uint8_t* pByte;
        int16_t* pInt;
        uint16_t* pErr;
        int32_t* pLng;
        int64_t* pLngLng;
        _VB_CURRENCY* pCur;
        _VB_DECIMAL* pDec;
        float* pSng;
        double* pDbl;
        _VB_DATE* pDtm;
        _VB_STRING* pStr;
    } Data;
} _VB_VARIANT;
This definition is not complete,
but will have to suffice for now

IUnknown is defined as:

typedef struct IUnknown {
    uintptr_t (*QueryInterface)(void*, _VB_GUID*, void**);
    int32_t (*AddRef)(void*);
    int32_t (*Release)(void*);
    int32_t (*Initialize)(void*);
    int32_t (*Terminate)(void*);
    uint32_t _RefCount;
} IUnknown;

While _VB_GUID is defined as:

typedef struct _VB_GUID {
    int32_t Data1;
    int32_t Data2;
    int32_t Data3;
    uint8_t Data4[8];
} _VB_GUID;

If you know COM, you'll notice that I took some liberty when defining IUnkown, as I sneaked Initialize and Terminate pointers there, where they do not belong.
I did not define Object yet because it is a pointer to an IDispatch interface.
I'm planning to define IDispatch in my next post.

Here are some VB buil-in constants and their C counterparts:

VB C
True const _VB_BOOLEAN _VB_TRUE = -1;
False const _VB_BOOLEAN _VB_FALSE = 0;
Empty const _VB_VARIANT _VB_EMPTY = {0};
Null const _VB_VARIANT _VB_NULL = { .TypeDescriptor = 1, .Data = {0} };
Nothing #define _VB_NOTHING NULL

(I know that names starting with an underscore followed by a capital letter are reserved in C.
I'll come up with a better convention later.)

Now, strings.
In VB, they are a pointer to a structure starting with a Long (the length), followed by a chain of wchar_ts, ending with a null wchar_t.
The thing is, the pointer points to the first wchar_t after the initial Long.

So, a string literal goes like this:
  1. "This is a string" is a chain of chars;
  2. u"This is a string" is a chain of wchar_ts;
  3. u"\0x20\0This is a string" is a chain of wchar_ts preceded by string's length in bytes;
  4. u"\0x20\0This is a string\0" is a chain of wchar_ts preceded by string's length in bytes and terminated by a null wchar_t;
  5. u"\0x20\0This is a string\0"[2] is a wchar_t at index 2 ("T");
  6. &u"\0x20\0This is a string\0"[2] is a pointer to the wchar_t at index 2 ("T");
  7. _VB_STRING Text = &u"\0x20\0This is a string\0"[2] is a valid VB string literal. Phew!
To transpile classes, I'm relying heavily on this article: COM in Plain C.
That is, I need to provide a CLSID (a GUID identifying a class), an IID (a GUID identifying the class' interface), a structure to represent the class, and another structure to be class' VTable (virtual table.)
So far, every time I run the transpiler, it generates a different pair of CLSID and IID for each class.
When I add the ability to parse Tuples to our transpiler, those GUID's can be embedded in classes as attributes, so we won't need to regenerate them over and over.

Right now I'm generating empty constructors (Sub Class_Initialize) and destructors (Sub Class_Terminate).
When we start transpiling methods, we'll fill them with their code.
I'm not even generating classes' full VTables yet. Their subs, functions, properties, and other classes' implementations are being skipped.
I hope to do them in my next post, too.

Public Consts, Enums, and Types are being printed to class' .H (header) file.
Friend and Private ones are being generated only inside class' .C file.

So, how does a class look when transpiled? Like this:

VB C
Public Class ConstDataType
Option Explicit
Implements DataType

Private Id_ As Identifier
Private Pad_ As Pad
Private Const_ As ConstConstruct

Private Sub Class_Initialize()
Dim Token As Token

Set Token = New Token
Token.Kind = tkKeyword
Token.Code = kwLong
Set Id_ = NewId(Token)
End Sub

Public Property Set Constant(ByVal Value As ConstConstruct)
Set Const_ = Value
End Property

Public Property Set Pad(ByVal Value As Pad)
Set Pad_ = New Pad
Set Pad_.Project = Value.Project
Set Pad_.Source = Value.Source
Set Pad_.Entity = Value.Entity
Set Pad_.Method = Value.Method
Set Pad_.Parent = Value.Parent
End Property

Public Property Set FixedLength(ByVal Value As IExpression)
Err.Raise 5
End Property

Public Property Get FixedLength() As IExpression
End Property

Public Property Set Id(ByVal Value As Identifier)
Set Id_ = Value
End Property

Public Property Get Id() As Identifier
Resolve
Set Id = Id_
End Property

Public Property Let IsArray(ByVal Value As Boolean)
Err.Raise 5
End Property

Public Property Get IsArray() As Boolean
End Property

Private Property Set DataType_FixedLength(ByVal Value As IExpression)
Set FixedLength = Value
End Property

Private Property Get DataType_FixedLength() As IExpression
Set DataType_FixedLength = FixedLength
End Property

Private Property Set DataType_Id(ByVal Value As Identifier)
Set Id_ = Value
End Property

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

Private Property Let DataType_IsArray(ByVal Value As Boolean)
IsArray = Value
End Property

Private Property Get DataType_IsArray() As Boolean
DataType_IsArray = IsArray
End Property

Private Sub Resolve()
Dim Vt As VbVarType

If Const_ Is Nothing Then Exit Sub

Vt = InferType(Pad_, Const_.Value)
Id_.Name.Code = VtToKw(Vt)
Set Const_ = Nothing
End Sub
End Class
//This is the .H file
#ifndef VB_CONSTDATATYPE_H
#define VB_CONSTDATATYPE_H
#include "_basic.h"

_VB_GUID _CLSID_ConstDataType;
_VB_GUID _IID_ConstDataType;
typedef struct _ConstDataType _ConstDataType;
typedef struct _ConstDataType * ConstDataType;
ConstDataType _NewConstDataType(void);
#endif

//This is the .C file
#include "_header.h"

_VB_GUID _CLSID_ConstDataType = {
.Data1 = 0x488B3A46,
.Data2 = 0x46D88C93,
.Data3 = 0xA1C89D8D,
.Data4 = { 0x5B, 0x2D, 0x56, 0x99, 0x0, 0x0, 0x0, 0x0 }
};

_VB_GUID _IID_ConstDataType = {
.Data1 = 0x98C171ED,
.Data2 = 0x46CA4DE8,
.Data3 = 0x2460585,
.Data4 = { 0x14, 0xF5, 0xCB, 0x8F, 0x0, 0x0, 0x0, 0x0 }
};

struct _ConstDataType {
struct _ConstDataTypeVtbl* Vtbl;
//private variables
Identifier Id_;
Pad Pad_;
ConstConstruct Const_;
};

static int32_t __stdcall _ConstDataType_QueryInterface(IUnknown * const this, _VB_GUID* riid, void** result) {
if (CMP_GUIDS(riid, &IID_IUnknown) || CMP_GUIDS(riid, &IID_ConstDataType)) {
*result = this;
_AddRef(this);
return 0; //NOERROR
}

*result = _VB_NOTHING;
return 0x80004002; //E_NOINTERFACE
}

static int32_t __stdcall _ConstDataType_Initialize(ConstDataType const this) {
return 0; //S_OK
}

static int32_t __stdcall _ConstDataType_Terminate(ConstDataType const this) {
return 0; //S_OK
}

struct _ConstDataTypeVtbl {
int32_t __stdcall (*QueryInterface)(IUnknown*, _VB_GUID*, void**);
int32_t __stdcall (*AddRef)(IUnknown*);
int32_t __stdcall (*Release)(IUnknown*);
int32_t __stdcall (*Initialize)(ConstDataType);
int32_t __stdcall (*Terminate)(ConstDataType);
uint32_t _RefCount;
//public methods
} static _ConstDataType_Vtbl = {_ConstDataType_QueryInterface, _AddRef, _Release, _ConstDataType_Initialize, _ConstDataType_Terminate, 0};

ConstDataType _NewConstDataType(void) {
ConstDataType result = malloc(sizeof(_ConstDataType));
result->Vtbl = &_ConstDataType_Vtbl;
result->Vtbl->_RefCount = 0;
result->Vtbl->AddRef((IUnknown*)result);
result->Vtbl->Initialize(result);
return result;
}

I'm testing it with GCC, and it seems to generate valid C code.
I forgot to mention I tested compiling VB code to a console program using this tip. It worked like a charm.

Holy moly! Sh*t is getting real!
Next week, I intend to do so many things...

Andrej Biasic
2021-08-11

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
Public EntryIndex As Long

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


Public Class ConstDataType
Option Explicit
Implements DataType

Private Id_ As Identifier
Private Pad_ As Pad
Private Const_ As ConstConstruct

Private Sub Class_Initialize()
Dim Token As Token

Set Token = New Token
Token.Kind = tkKeyword
Token.Code = kwLong
Set Id_ = NewId(Token)
End Sub

Public Property Set Constant(ByVal Value As ConstConstruct)
Set Const_ = Value
End Property

Public Property Set Pad(ByVal Value As Pad)
Set Pad_ = New Pad
Set Pad_.Project = Value.Project
Set Pad_.Source = Value.Source
Set Pad_.Entity = Value.Entity
Set Pad_.Method = Value.Method
Set Pad_.Parent = Value.Parent
End Property

Public Property Set FixedLength(ByVal Value As IExpression)
Err.Raise 5
End Property

Public Property Get FixedLength() As IExpression
End Property

Public Property Set Id(ByVal Value As Identifier)
Set Id_ = Value
End Property

Public Property Get Id() As Identifier
Resolve
Set Id = Id_
End Property

Public Property Let IsArray(ByVal Value As Boolean)
Err.Raise 5
End Property

Public Property Get IsArray() As Boolean
End Property

Private Property Set DataType_FixedLength(ByVal Value As IExpression)
Set FixedLength = Value
End Property

Private Property Get DataType_FixedLength() As IExpression
Set DataType_FixedLength = FixedLength
End Property

Private Property Set DataType_Id(ByVal Value As Identifier)
Set Id_ = Value
End Property

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

Private Property Let DataType_IsArray(ByVal Value As Boolean)
IsArray = Value
End Property

Private Property Get DataType_IsArray() As Boolean
DataType_IsArray = IsArray
End Property

Private Sub Resolve()
Dim Vt As VbVarType

If Const_ Is Nothing Then Exit Sub

Vt = InferType(Pad_, Const_.Value)
Id_.Name.Code = VtToKw(Vt)
Set Const_ = Nothing
End Sub
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

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 CTranslator
Option Explicit

Private Declare Function CoCreateGuid Lib "OLE32.DLL" (ByRef pGuid As GUID) As Long
Private Pad_ As Pad

Public Sub Transpile(ByVal Prj As Project)
On Error GoTo ErrHandler
Set Pad_ = New Pad
Set Pad_.Project = Prj

GenerateBasicFiles Prj
GenerateConstFiles Prj
GenerateEnumFiles Prj
GenerateTypeFiles Prj
GenerateClasses Prj

Exit Sub

ErrHandler:
ErrReraise "CTranslator.Transile"
End Sub

Private Function CreateBuilder(ByVal Path As String) As ITextBuilder
Dim Result As FileTextBuilder

Set Result = New FileTextBuilder
Result.FilePath = Path
Set CreateBuilder = Result
End Function

Private Sub GenerateBasicFiles(ByVal Prj As Project)
Dim Bldr As ITextBuilder

Set Bldr = CreateBuilder(Prj.BuildPath & "_basic.h")

With Bldr
.AppendLn "#ifndef VB_BAS_H"
.AppendLn "#define VB_BAS_H"
.AppendLn "#include <inttypes.h>"
.AppendLn "#include <stdlib.h>"
.AppendLn

.AppendLn "#define CMP_GUIDS(G1, G2) \"
.Indent
.AppendLn "( \"
.Indent
.AppendLn "(G1)->Data1 == (G2)->Data1 && \"
.AppendLn "(G1)->Data2 == (G2)->Data2 && \"
.AppendLn "(G1)->Data3 == (G2)->Data3 && \"
.AppendLn "(G1)->Data4[0] == (G2)->Data4[0] && \"
.AppendLn "(G1)->Data4[1] == (G2)->Data4[1] && \"
.AppendLn "(G1)->Data4[2] == (G2)->Data4[2] && \"
.AppendLn "(G1)->Data4[3] == (G2)->Data4[3] && \"
.AppendLn "(G1)->Data4[4] == (G2)->Data4[4] && \"
.AppendLn "(G1)->Data4[5] == (G2)->Data4[5] && \"
.AppendLn "(G1)->Data4[6] == (G2)->Data4[6] && \"
.AppendLn "(G1)->Data4[7] == (G2)->Data4[7] \"
.Deindent
.AppendLn ")"
.Deindent
.AppendLn

Rem Boolean
.AppendLn "typedef int16_t _VB_BOOLEAN;"
.AppendLn "const _VB_BOOLEAN _VB_TRUE = -1;"
.AppendLn "const _VB_BOOLEAN _VB_FALSE = 0;"

Rem Currency
.AppendLn "typedef int64_t _VB_CURRENCY;"

Rem Decimal
.AppendLn "typedef struct _VB_DECIMAL {"
.Indent
.AppendLn "int16_t TypeDescriptor;"
.AppendLn "uint8_t Scale;"
.AppendLn "uint8_t Sign;"
.AppendLn "int32_t High;"
.AppendLn "int32_t Low;"
.AppendLn "int32_t Middle;"
.Deindent
.AppendLn "} _VB_DECIMAL;"
.AppendLn

Rem Date
.AppendLn "typedef double _VB_DATE;"

Rem String
.AppendLn "typedef wchar_t* _VB_STRING;"

Rem GUID
.AppendLn "typedef struct _VB_GUID {"
.Indent
.AppendLn "int32_t Data1;"
.AppendLn "int16_t Data2;"
.AppendLn "int16_t Data3;"
.AppendLn "uint8_t Data4[8];"
.Deindent
.AppendLn "} _VB_GUID;"
.AppendLn

Rem IUnknown
.AppendLn "typedef struct IUnknown {"
.Indent
.AppendLn "uintptr_t (*QueryInterface)(void*, _VB_GUID*, void**);"
.AppendLn "int32_t (*AddRef)(void*);"
.AppendLn "int32_t (*Release)(void*);"
.AppendLn "int32_t (*Initialize)(void*);"
.AppendLn "int32_t (*Terminate)(void*);"
.AppendLn "uint32_t _RefCount;"
.Deindent
.AppendLn "} IUnknown;"
.AppendLn

Rem Variant
.AppendLn "typedef struct _VB_VARIANT {"
.Indent
.AppendLn "int16_t TypeDescriptor;"
.AppendLn
.AppendLn "union {"
.Indent
.AppendLn "_VB_BOOLEAN tBool;"
.AppendLn "uint8_t tByte;"
.AppendLn "int16_t tInt;"
.AppendLn "uint16_t tErr;"
.AppendLn "int32_t tLng;"
.AppendLn "int64_t tLngLng;"
.AppendLn "_VB_CURRENCY tCur;"
.AppendLn "_VB_DECIMAL tDec;"
.AppendLn "float tSng;"
.AppendLn "double tDbl;"
.AppendLn "_VB_DATE tDtm;"
.AppendLn "_VB_STRING tStr;"
.AppendLn "IUnknown* tObj;"
.AppendLn "_VB_BOOLEAN* pBool;"
.AppendLn "uint8_t* pByte;"
.AppendLn "int16_t* pInt;"
.AppendLn "uint16_t* pErr;"
.AppendLn "int32_t* pLng;"
.AppendLn "int64_t* pLngLng;"
.AppendLn "_VB_CURRENCY* pCur;"
.AppendLn "_VB_DECIMAL* pDec;"
.AppendLn "float* pSng;"
.AppendLn "double* pDbl;"
.AppendLn "_VB_DATE* pDtm;"
.AppendLn "_VB_STRING* pStr;"
.Deindent
.AppendLn "} Data;"
.Deindent
.AppendLn "} _VB_VARIANT;"
.AppendLn

Rem Empty
.AppendLn "const _VB_VARIANT _VB_EMPTY = {0};"

Rem Null
.AppendLn "const _VB_VARIANT _VB_NULL = { .TypeDescriptor = 1, .Data = {0} };"

Rem Nothing
.AppendLn "#define _VB_NOTHING NULL"

Rem IID_IUnknown
.AppendLn "_VB_GUID IID_IUnknown = {"
.Indent
.AppendLn ".Data1 = 0,"
.AppendLn ".Data2 = 0,"
.AppendLn ".Data3 = 0,"
.AppendLn ".Data4 = { 0xC0, 0, 0, 0, 0, 0, 0, 0x46 }"
.Deindent
.AppendLn "};"
.AppendLn

.AppendLn "int32_t __stdcall _AddRef(IUnknown* const this) {"
.Indent
.AppendLn "++this->_RefCount;"
.AppendLn "return this->_RefCount;"
.Deindent
.AppendLn "}"
.AppendLn

.AppendLn "int32_t __stdcall _Release(IUnknown* const this) {"
.Indent
.AppendLn "--this->_RefCount;"
.AppendLn
.AppendLn "if (this->_RefCount == 0) {"
.Indent
.AppendLn "this->Terminate(this);"
.AppendLn "free(this);"
.AppendLn "return 0;"
.Deindent
.AppendLn "}"
.AppendLn
.AppendLn "return this->_RefCount;"
.Deindent
.AppendLn "}"
.AppendLn

.AppendLn "#endif"
End With
End Sub

Private Sub GenerateConstFiles(ByVal Prj As Project)
Dim Value As Variant
Dim Enty As Entity
Dim Source As SourceFile
Dim HFile As ITextBuilder
Dim Cnt As ConstConstruct

On Error GoTo ErrHandler
Set HFile = CreateBuilder(Prj.BuildPath & "_consts.h")

With HFile
.AppendLn "#ifndef VB_CONST_H"
.AppendLn "#define VB_CONST_H"

.AppendLn "#include ""_basic.h"""
.AppendLn

For Each Source In Prj.SourceFiles
Set Pad_.Source = Source

For Each Enty In Source.Entities
Set Pad_.Entity = Enty
Set Pad_.Parent = Nothing
Set Pad_.Method = Nothing

For Each Cnt In Enty.Consts
Do
If Cnt.Access <> acFriend And Cnt.Access <> acPublic Then Exit Do

.Append "const "
PrintDataType HFile, Cnt.DataType
.Append " "
PrintId HFile, Cnt.Id

If Not Cnt.DataType.FixedLength Is Nothing Then
.Append "["
PrintExpression HFile, Cnt.DataType.FixedLength
.Append "]"
End If

.Append " = "
Value = Evaluate(Pad_, Cnt.Value)

If VarType(Value) = vbString Then
PrintString HFile, Value
Else
HFile.Append Value
End If

.AppendLn ";"
Loop While False
Next
Next
Next

.AppendLn
.AppendLn "#endif"
End With

Exit Sub

ErrHandler:
ErrReraise "GenerateConstHeader"
End Sub

Private Sub GenerateEnumFiles(ByVal Prj As Project)
Dim Count As Integer
Dim Value As Long
Dim Enty As Entity
Dim Source As SourceFile
Dim HFile As ITextBuilder
Dim Enm As EnumConstruct
Dim Member As EnumerandConstruct

On Error GoTo ErrHandler
Set HFile = CreateBuilder(Prj.BuildPath & "_enums.h")

With HFile
.AppendLn "#ifndef VB_ENUM_H"
.AppendLn "#define VB_ENUM_H"
.AppendLn

For Each Source In Prj.SourceFiles
Set Pad_.Source = Source

For Each Enty In Source.Entities
Set Pad_.Entity = Enty
Set Pad_.Method = Nothing

For Each Enm In Enty.Enums
Set Pad_.Parent = Enm

Value = 0
Count = 0

Do
If Enm.Access <> acFriend And Enm.Access <> acPublic Then Exit Do

.AppendLn "typedef enum {"
.Indent

For Each Member In Enm.Enumerands
PrintId HFile, Member.Id
.Append " = "

If Not Member.Value Is Nothing Then Value = Evaluate(Pad_, Member.Value)

.Append CStr(Value)
Value = Value + 1
Count = Count + 1

If Count <> Enm.Enumerands.Count Then .Append ","
.AppendLn
Next

.Deindent
.Append "} "
PrintId HFile, Enm.Id
.AppendLn ";"
.AppendLn
Loop While False
Next
Next
Next

.AppendLn "#endif"
End With

Exit Sub

ErrHandler:
ErrReraise "GenerateEnumHeader"
End Sub

Private Sub GenerateTypeFiles(ByVal Prj As Project)
Dim Enty As Entity
Dim Mem As Variable
Dim Source As SourceFile
Dim HFile As ITextBuilder
Dim Udt As TypeConstruct

On Error GoTo ErrHandler
Set HFile = CreateBuilder(Prj.BuildPath & "_types.h")

With HFile
.AppendLn "#ifndef VB_TYPE_H"
.AppendLn "#define VB_TYPE_H"
.AppendLn "#include ""_basic.h"""
.AppendLn

For Each Source In Prj.SourceFiles
Set Pad_.Source = Source

For Each Enty In Source.Entities
Set Pad_.Entity = Enty
Set Pad_.Method = Nothing

For Each Udt In Enty.Types
Set Pad_.Parent = Udt

Do
If Udt.Access <> acFriend And Udt.Access <> acPublic Then Exit Do

.AppendLn "typedef struct {"
.Indent

For Each Mem In Udt.Members
PrintDim HFile, Prj, Mem
Next

.Deindent
.Append "} "
PrintId HFile, Udt.Id
.AppendLn ";"
Loop While False
Next
Next
Next

.AppendLn
.AppendLn "#endif"
End With

Exit Sub

ErrHandler:
ErrReraise "GenerateTypeHeader"
End Sub

Private Sub GenerateClasses(ByVal Prj As Project)
Dim Value As Long
Dim Count As Integer
Dim IName As String
Dim Enty As Entity
Dim Var As Variable
Dim Source As SourceFile
Dim HFile As ITextBuilder
Dim CFile As ITextBuilder
Dim RFile As ITextBuilder
Dim Udt As TypeConstruct
Dim Enm As EnumConstruct
Dim Cnt As ConstConstruct
Dim Member As EnumerandConstruct

On Error GoTo ErrHandler

Set RFile = CreateBuilder(Prj.BuildPath & Prj.Name & ".c")

With RFile
.AppendLn "#include <stdlib.h>"
.AppendLn "#include ""_basic.h"""
.AppendLn "#include ""_consts.h"""
.AppendLn "#include ""_enums.h"""
.AppendLn "#include ""_types.h"""
End With

For Each Source In Prj.SourceFiles
Set Pad_.Source = Source

For Each Enty In Source.Entities
Set Pad_.Entity = Enty
Set Pad_.Parent = Nothing
Set Pad_.Method = Nothing

IName = NameBank(Enty.Id.Name)

Rem One header to rule them all
RFile.Append "#include """
RFile.Append IName
RFile.AppendLn ".h"""

Set HFile = CreateBuilder(Prj.BuildPath & IName & ".h")
Rem Guard
HFile.Append "#ifndef VB_"
HFile.Append UCase$(IName)
HFile.AppendLn "_H"
HFile.Append "#define VB_"
HFile.Append UCase$(IName)
HFile.AppendLn "_H"
HFile.AppendLn "#include ""_basic.h"""
HFile.AppendLn

Set CFile = CreateBuilder(Prj.BuildPath & IName & ".c")

With CFile
.AppendLn "#include ""_header.h"""
.AppendLn

Rem Consts
For Each Cnt In Enty.Consts
If Cnt.Access = acLocal Or Cnt.Access = acPrivate Then
.Append "static const "
PrintDataType CFile, Cnt.DataType
.Append " "
PrintId CFile, Cnt.Id

If Not Cnt.DataType.FixedLength Is Nothing Then
.Append "["
PrintExpression CFile, Cnt.DataType.FixedLength
.Append "]"
End If

.Append " = "
PrintExpression CFile, Cnt.Value
.AppendLn ";"
End If
Next

Rem Enums
For Each Enm In Enty.Enums
Set Pad_.Parent = Enm
Value = 0
Count = 0

If Enm.Access = acLocal Or Enm.Access = acPrivate Then
.AppendLn "typedef enum {"
.Indent

For Each Member In Enm.Enumerands
PrintId CFile, Member.Id
.Append " = "

If Not Member.Value Is Nothing Then Value = Evaluate(Pad_, Member.Value)

.Append CStr(Value)
Value = Value + 1
Count = Count + 1

If Count <> Enm.Enumerands.Count Then .Append ","
.AppendLn
Next

.Deindent
.Append "} "
PrintId CFile, Enm.Id
.AppendLn ";"
End If
Next

Rem Types
For Each Udt In Enty.Types
Set Pad_.Parent = Udt

If Udt.Access = acLocal Or Udt.Access = acPrivate Then
.AppendLn "typedef struct {"
.Indent

For Each Var In Udt.Members
PrintDim CFile, Prj, Var
Next

.Deindent
.Append "} "
PrintId CFile, Udt.Id
.AppendLn ";"
End If
Next

Set Pad_.Parent = Nothing

If Enty.IsClass Then
Rem CLSID in header file
HFile.Append "_VB_GUID _CLSID_"
HFile.Append IName
HFile.AppendLn ";"

Rem CLSID in class file
.Append "_VB_GUID _CLSID_"
.Append IName
PrintGuid CFile
.AppendLn

Rem IID in header file
HFile.Append "_VB_GUID _IID_"
HFile.Append IName
HFile.AppendLn ";"

Rem IID in class in file
.Append "_VB_GUID _IID_"
.Append IName
PrintGuid CFile
.AppendLn

Rem Class in header file
HFile.Append "typedef struct _"
HFile.Append IName
HFile.Append " _"
HFile.Append IName
HFile.AppendLn ";"

Rem Pointer to class in class file
HFile.Append "typedef struct _"
HFile.Append IName
HFile.Append " * "
HFile.Append IName
HFile.AppendLn ";"

Rem Class interface vtable
.Append "struct _"
.Append IName
.AppendLn " {"
.Indent
.Append "struct _"
.Append IName
.AppendLn "Vtbl* Vtbl;"

If Enty.Vars.Count > 0 Then .AppendLn "//private variables"

For Each Var In Enty.Vars
If Var.Access = acPrivate Then PrintDim CFile, Prj, Var, UseSafeArray:=True
Next

.Deindent
.AppendLn "};"
.AppendLn

Rem QueryInterface implementation
.Append "static int32_t __stdcall _"
.Append IName
.Append "_QueryInterface(IUnknown * const this, _VB_GUID* riid, void** result) {"
.Indent
.Append "if (CMP_GUIDS(riid, &IID_IUnknown) || CMP_GUIDS(riid, &IID_"
.Append IName
.AppendLn ")) {"
.Indent
.AppendLn "*result = this;"
.AppendLn "_AddRef(this);"
.AppendLn "return 0; //NOERROR"
.Deindent
.AppendLn "}"
.AppendLn

.AppendLn "*result = _VB_NOTHING;"
.AppendLn "return 0x80004002; //E_NOINTERFACE"
.Deindent
.AppendLn "}"
.AppendLn

Rem Initialize implementation
.Append "static int32_t __stdcall _"
.Append IName
.Append "_Initialize("
.Append IName
.AppendLn " const this) {"
.Indent
Rem TODO: Translate Class_Initialize's code
.AppendLn "return 0; //S_OK"
.Deindent
.AppendLn "}"
.AppendLn

Rem Terminate implementation
.Append "static int32_t __stdcall _"
.Append IName
.Append "_Terminate("
.Append IName
.AppendLn " const this) {"
.Indent
Rem TODO: Translate Class_Terminate's code
.AppendLn "return 0; //S_OK"
.Deindent
.AppendLn "}"
.AppendLn

Rem IUnknown implementation
.Append "struct _"
.Append IName
.AppendLn "Vtbl {"
.Indent
.AppendLn "int32_t __stdcall (*QueryInterface)(IUnknown*, _VB_GUID*, void**);"

.AppendLn "int32_t __stdcall (*AddRef)(IUnknown*);"

.AppendLn "int32_t __stdcall (*Release)(IUnknown*);"

.Append "int32_t __stdcall (*Initialize)("
.Append IName
.AppendLn ");"

.Append "int32_t __stdcall (*Terminate)("
.Append IName
.AppendLn ");"

.AppendLn "uint32_t _RefCount;"
.AppendLn "//public methods"
Rem TODO: Translate class' public methods' signatures
.Deindent
.Append "} static _"
.Append IName
.Append "_Vtbl = {_"
.Append IName
.Append "_QueryInterface, _AddRef, _Release, _"
.Append IName
.Append "_Initialize, _"
.Append IName
.AppendLn "_Terminate, 0};"
.AppendLn

Rem TODO: Translate class' public methods' implementation

Rem Constructor in header file
HFile.Append IName
HFile.Append " _New"
HFile.Append IName
HFile.AppendLn "(void);"

Rem Constructor in class file
.Append IName
.Append " _New"
.Append IName
.AppendLn "(void) {"
.Indent
.Append IName
.Append " result = malloc(sizeof(_"
.Append IName
.AppendLn "));"
'.AppendLn "if (result == _VB_NOTHING) printf(""%s"", ""NO MEMORY!\n"");"
.Append "result->Vtbl = &_"
.Append IName
.AppendLn "_Vtbl;"
.AppendLn "result->Vtbl->_RefCount = 0;"
.AppendLn "result->Vtbl->AddRef((IUnknown*)result);"
.AppendLn "result->Vtbl->Initialize(result);"
.AppendLn "return result;"
.Deindent
.AppendLn "}"
.AppendLn
End If
End With

HFile.AppendLn "#endif"
HFile.AppendLn
Next
Next

RFile.AppendLn "#endif"
Exit Sub

ErrHandler:
ErrReraise "GenerateClasses"
End Sub

Private Sub PrintId(ByVal Bldr As ITextBuilder, ByVal Id As Identifier)
Dim Index As Long
Dim Name As String

If Id.Name.Kind = tkCrazyIdentifier Then
Name = GenId
Index = NameBank.FromIdIndex(Id.Name.Code)
NameBank.Ids.Remove Index
NameBank.Ids.Add Name, Name, Before:=Index
Id.Name.Kind = tkIdentifier
Else
Name = NameBank(Id.Name)
End If

Bldr.Append Name
End Sub

Private Sub PrintDataType(ByVal Bldr As ITextBuilder, ByVal Data As DataType)
With Bldr
Select Case Data.Id.Name.Code
Case kwBoolean
.Append "_VB_BOOLEAN"

Case kwByte
.Append "uint8_t"

Case kwInteger
.Append "int16_t"

Case kwLong
.Append "int32_t"

Case kwLongLong
.Append "int64_t"

Case kwLongPtr
.Append "uintptr_t"

Case kwCurrency
.Append "_VB_CURRENCY"

Case cxDecimal
.Append "_VB_DECIMAL"

Case kwSingle
.Append "float"

Case kwDouble
.Append "double"

Case kwDate
.Append "_VB_DATE"

Case kwString
If Data.FixedLength Is Nothing Then
.Append "_VB_STRING"
Else
.Append "wchar_t*"
End If

Case cxObject
.Append "IUnknown*"

Case kwVariant
.Append "_VB_VARIANT"

Case Else
Debug.Assert Data.Id.Name.Code
PrintId Bldr, Data.Id
End Select
End With
End Sub

Private Sub PrintExpression(ByVal Bldr As ITextBuilder, ByVal Expr As IExpression)
Dim Txt As String
Dim Sym As Symbol
Dim Lit As Literal
Dim Hnd As FileHandle
Dim Prc As CallConstruct
Dim Uni As UnaryExpression
Dim Bin As BinaryExpression

On Error GoTo ErrHandler

With Bldr
Select Case Expr.Kind
Case ekUnaryExpr
Set Uni = Expr

Select Case Uni.Operator.Value.Code
Case opNot
.Append "~"

Case opNeg
.Append "-"
End Select

PrintExpression Bldr, Uni.Value

Case ekBinaryExpr
Set Bin = Expr
.Append "("
PrintExpression Bldr, Bin.LHS

Select Case Bin.Operator.Value.Code
Case opAnd
.Append " & "

Case opConcat
.Append " + "

Case opDiv
.Append " / "

Case opEq, opIs
.Append " == "

'Case opEqv
'Stop

Case opGe
.Append " >= "

Case opGt
.Append " > "

'Case opImp
'Stop

'Case opIntDiv
'Stop

Case opIsNot, opNe
.Append " != "

Case opLe
.Append " <= "

'Case opLike
'Stop

Case opLSh
.Append " << "

Case opLt
.Append " < "

Case opMod
.Append " % "

Case opMul
.Append " * "

Case opOr
.Append " | "

'Case opPow
'Stop

Case opRSh
.Append ">>"

Case opSubt
.Append " - "

Case opSum
.Append " = "

'Case opURSh
'Stop

Case opXor
.Append " ^ "
End Select

PrintExpression Bldr, Bin.RHS
.Append ")"

Case ekLiteral
Set Lit = Expr

Select Case Lit.Value.Kind
Case tkIntegerNumber
If Left$(Lit.Value.Text, 1) = "+" Then
.Append Mid$(Lit.Value.Text, 2)
Else
.Append Lit.Value.Text
End If

Case tkBinaryNumber
Debug.Assert False

Case tkOctalNumber
.Append "0"

If Left$(Lit.Value.Text, 1) = "+" Then
.Append Mid$(Lit.Value.Text, 2)
Else
.Append Lit.Value.Text
End If

Case tkHexaNumber
.Append "0x"

If Left$(Lit.Value.Text, 1) = "+" Then
.Append Mid$(Lit.Value.Text, 2)
Else
.Append Lit.Value.Text
End If

Case tkFloatNumber, tkSciNumber
.Append Lit.Value.Text

Case tkString
PrintString Bldr, Lit.Value.Text

Case tkDateTime
Debug.Assert False
.Append CDbl(CDate(Lit.Value.Text))

Case tkKeyword
Select Case Lit.Value.Code
Case kwEmpty
.Append "_VB_EMPTY"

Case kwTrue
.Append "_VB_TRUE"

Case kwFalse
.Append "_VB_FALSE"

Case kwNull
.Append "_VB_NULL"

Case kwNothing
.Append "_VB_NOTHING"

Case kwMe
.Append "this"

Case Else
Debug.Assert False
End Select
End Select

Case ekSymbol
Set Sym = Expr
PrintToken Bldr, Sym.Value

Case ekIndexer
Set Prc = Expr

If TypeOf Prc.LHS Is Symbol Then
Set Sym = Prc.LHS

If UCase$(NameBank(Sym.Value)) = "CHR" Then
Set Lit = Prc.Arguments(1)

Select Case Lit.Value.Text
Case "+0"
.Append "u""\1\0\0"""

Case "+7"
.Append "u""\1\0\a"""

Case "+8"
.Append "u""\1\0\b"""

Case "+9"
.Append "u""\1\0\t"""

Case "+10"
.Append "u""\1\0\n"""

Case "+11"
.Append "u""\1\0\v"""

Case "+12"
.Append "u""\1\0\f"""

Case "+13"
.Append "u""\1\0\r"""

Case Else
.Append "u""\1\0\x"
.Append Hex$(CInt(Prc.Arguments(1)))
.Append """"
End Select
Else
Debug.Assert False
End If
Else
Debug.Assert False
End If

Case ekFileHandle
Debug.Assert False
Set Hnd = Expr
.Append NameBank(Hnd.Value)

Case ekTuple
Rem Not implemented
Debug.Assert False
End Select
End With

Exit Sub

ErrHandler:
ErrReraise "PrintExpression"
End Sub

Private Sub PrintToken(ByVal Bldr As ITextBuilder, ByVal Token As Token)
With Bldr
Select Case Token.Kind
Case tkIdentifier
.Append NameBank(Token)

Case Else
Debug.Assert False
End Select
End With
End Sub

Private Sub PrintDim( _
ByVal Bldr As ITextBuilder, _
ByVal Prj As Project, _
ByVal Var As Variable, _
Optional ByVal IsStatic As Boolean, _
Optional ByVal UseSafeArray As Boolean _
)
Dim Count As Integer
Dim Pair As SubscriptPair

On Error GoTo ErrHandler

With Bldr
If IsStatic Then .Append "static "
PrintDataType Bldr, Var.DataType
.Append " "
PrintId Bldr, Var.Id

If Var.Subscripts.Count Then
If UseSafeArray Then
.AppendLn "// TODO: SAFE_ARRAY"
Else
.Append "["

For Each Pair In Var.Subscripts
.Append Evaluate(Pad_, Pair.UpperBound) - Evaluate(Pad_, Pair.LowerBound) + 1
Count = Count + 1
If Count <> Var.Subscripts.Count Then .Append ", "
Next

.Append "]"
End If
End If

If Not Var.Init Is Nothing Then
.Append " = "
PrintExpression Bldr, Var.Init
End If

.AppendLn ";"
End With

Exit Sub

ErrHandler:
ErrReraise "PrintDim"
End Sub

Private Sub PrintGuid(ByVal Bldr As ITextBuilder)
Dim G As GUID

CoCreateGuid G

With Bldr
.AppendLn " = {"
.Indent
.Append ".Data1 = 0x"
.Append Hex$(G.Data1)
.AppendLn ","

.Append ".Data2 = 0x"
.Append Hex$(G.Data2)
.AppendLn ","

.Append ".Data3 = 0x"
.Append Hex$(G.Data3)
.AppendLn ","

.Append ".Data4 = { 0x"
.Append Hex$(G.Data4(0))
.Append ", 0x"
.Append Hex$(G.Data4(1))
.Append ", 0x"
.Append Hex$(G.Data4(2))
.Append ", 0x"
.Append Hex$(G.Data4(3))
.Append ", 0x"
.Append Hex$(G.Data4(4))
.Append ", 0x"
.Append Hex$(G.Data4(5))
.Append ", 0x"
.Append Hex$(G.Data4(6))
.Append ", 0x"
.Append Hex$(G.Data4(7))
.AppendLn " }"
.Deindent
.AppendLn "};"
End With
End Sub

Private Sub PrintString(ByVal Bldr As ITextBuilder, ByVal Value As String)
Dim Idx As Long
Dim Length As Long
Dim Ch As Integer

Length = Len(Value)

With Bldr
.Append "&u"""

If Length >= &H10000 Then
Ch = Length Mod &H10000
GoSub Encode

Ch = Length \ &H10000
GoSub Encode
Else
Ch = Length
GoSub Encode
.Append "\0"
End If

For Idx = 1 To Length
Ch = AscW(Mid$(Value, Idx, 1))
GoSub Encode
Next

.Append "\0""[2]"
Exit Sub

Encode:
Select Case Ch
Case 0
.Append "\0"

Case 7
.Append "\a"

Case 8
.Append "\b"

Case 9
.Append "\t"

Case 10
.Append "\n"

Case 11
.Append "\v"

Case 12
.Append "\f"

Case 13
.Append "\r"

Case Is < 10
.Append "\"
.Append Ch

Case Is < 32
.Append "\x"
.Append Hex$(Ch)

Case AscW("""")
.Append "\"""

Case AscW("\")
.Append "\\"

Case Else
.Append ChrW$(Ch)
End Select

Return
End With
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 DEBUG_BUILD Then
If Condition Then Exit Sub
Beep
Stop
#End If
End Sub

Public Sub [Print](ParamArray Args())
End Sub
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
Public EntryIndex As Long

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 = VtToToken(VariableType)

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 Pad As Pad, ByVal Var As Variable, ByVal Name As String)
Vars_.Add Var, Name
Panel_.AddVar Pad.Source.Path, Var
SymTab.AddVar Pad, Var
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 HasIterator As Boolean
Public Access As Accessibility
Public Id As Identifier
Public StdLib As Boolean
Public EntryIndex As Long

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

Public Property Get Methods() As KeyedList
Dim Result As KeyedList
Dim Slot As PropertySlot
Dim Proc As SubConstruct
Dim Func As FunctionConstruct
Dim Prop As PropertyConstruct

Set Result = New KeyedList
'Set Result.T = NewValidator(IMethod)

For Each Proc In Subs_
Result.Add Proc, NameBank(Proc.Id.Name)
Next

For Each Func In Funcs_
Result.Add Func, NameBank(Func.Id.Name)
Next

For Each Slot In Props_
For Each Prop In Slot
Result.Add Prop, NameBank(Prop.Id.Name)
Next
Next

Set Methods = Result
End Property
End Class


Public Class EnumConstruct
Option Explicit

Private Enumerands_ As KeyedList

Public Access As Accessibility
Public Id As Identifier
Public EntryIndex As Long

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
Public EntryIndex As Long
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 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
Rem Used by PINQ
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
Public EntryIndex As Long

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_Body() As KeyedList
Set IMethod_Body = Body_
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_EntryIndex() As Long
IMethod_EntryIndex = EntryIndex
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
ekIndexer
ekSymbol
ekFileHandle
ekTuple
ekUnaryExpr
ekBinaryExpr
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 EntryIndex() As Long
End Property

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

Public Property Get Body() 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
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 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 Pad As Pad, ByVal Var As Variable, ByVal Name As String)
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

Friend Property Get Root() As KLNode
Set Root = Root_
End Property
End Class


Public Class KLEnumerator
Option Explicit

Private Root_ As KLNode
Private Current_ As KLNode
Private WithEvents VbEnum As VariantEnumerator

Public Property Set List(ByVal Value As KeyedList)
Set Root_ = Value.Root
Set Current_ = Root_
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 Current_ Is Nothing Then Exit Sub
If IsObject(Current_.Value) Then Set Items = Current_.Value Else Items = Current_.Value
Set Current_ = Current_.NextNode
Returned = 1
End Sub

Private Sub VbEnum_Reset(ByRef Data As Variant)
Set Current_ = Root_
End Sub

Private Sub VbEnum_Skip(ByVal Qty As Long, ByRef Data As Variant)
While Qty <> 0
Set Current_ = Current_.NextNode
Qty = Qty - 1
Wend
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 needs 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

Rem Dollar names
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 Pad
Option Explicit

Public Project As Project
Public Source As SourceFile
Public Entity As Entity
Public Parent As Object 'Enum or Type
Public Method As IMethod
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
Public EntryIndex As Long
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 State_ As NarrowContext
Private Pad_ As Pad

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

Public Property Get SourceFile() As SourceFile
Set SourceFile = Pad_.Source
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 left in Source's properties like Consts, Enums, etc.
Public Sub Parse(ByVal Prj As Project)
Dim Name As String
Dim Token As Token
Dim Mark As Token
Dim Entity As Entity
Dim Source As SourceFile
Dim AccessToken As AccessToken
Dim Func As FunctionConstruct

On Error GoTo ErrHandler

Set Pad_ = New Pad
Set Pad_.Project = Prj

Downgrade_ = False
WasAs_ = False
Set LastToken_ = New Token
State_ = ncNone
Set LookAhead_ = Nothing

For Each Source In Prj.SourceFiles
Set Pad_.Source = Source
Set Pad_.Method = Nothing
Set Pad_.Parent = Nothing

Set Scanner_ = New Scanner
Scanner_.OpenFile Pad_.Source.Path

Do
Set Entity = New Entity
Set Pad_.Entity = Entity
Set Pad_.Parent = Nothing
Set Pad_.Method = Nothing

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
Entity.StdLib = IsSystemClass(Entity.Id.Name)
Else
Entity.StdLib = IsSystemModule(Entity.Id.Name)
End If

SymTab.AddEntity Pad_, Entity
MustEatLineBreak

AccessToken = ParseDeclarationArea
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 Pad_.Source.Entities.Exists(Name) Then Fail Entity.Id.Name, m.AmbiguousName & Name
Pad_.Source.Entities.AddKeyValue Name, Entity
MustEatLineBreak
Loop
Next

For Each Func In Entity.Functions
If Func.IsIterator Then
Entity.HasIterator = True
Exit For
End If
Next

Exit Sub

ErrHandler:
ErrReraise "Parse"
End Sub

Private Function ParseDeclarationArea() 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 Entity As Entity
Dim Panel As ControlPanel
Dim Access As Accessibility

On Error GoTo ErrHandler
Set Entity = Pad_.Entity
Set Panel = New ControlPanel

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:
ErrReraise "ParseDeclarationArea"
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
Panel.BodyType = ewSub

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

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

Set Func = ParseFunction(Access, Panel, IsDefault)
Panel.Validate Pad_.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
Panel.BodyType = ewProperty

Set Prop = ParseProperty(Access, Panel, IsDefault)
Panel.Validate Pad_.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:
ErrReraise "ParseProcedureArea"
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:
ErrReraise "ParseDef"
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 Vt As VbVarType
Dim Token As Token
Dim Pend As ConstDataType
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)

Else
Set Pend = New ConstDataType
Set Pend.Pad = Pad_
Set Pend.Constant = Cnt
Set Cnt.DataType = Pend
Set Pend = Nothing
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 Pad_.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 Pad_.Method Is Nothing Then Pad_.Method.Consts.Add Cnt
Panel.AddConst Pad_.Source.Path, Cnt
SymTab.AddConst Pad_, Cnt

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:
ErrReraise "ParseConsts"
End Function

Private Sub ParseEnum(ByVal Access As Accessibility, ByVal Panel As ControlPanel)
Dim Count As Variant
Dim Tk As Token
Dim Token As Token
Dim Lt As Literal
Dim Enm As EnumConstruct
Dim Bin As BinaryExpression
Dim Mem As EnumerandConstruct
Dim Xp As New Expressionist

On Error GoTo ErrHandler
Count = 0
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)

Set Pad_.Parent = Enm
SymTab.AddEnum Pad_, Enm
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 Mem = New EnumerandConstruct
Mem.Access = Access
Set Mem.Id = NewId(Token)

Set Token = NextToken

If Token.IsOperator(opEq) Then
Set Mem.Value = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Mem.Value Is Nothing Then Fail Token, m.InvExpr
Count = Empty

ElseIf VarType(Count) = vbEmpty Then
Set Bin = New BinaryExpression
Set Bin.LHS = Enm.Enumerands(Enm.Enumerands.Count).Value

Set Tk = New Token
Tk.Code = opSum
Tk.Kind = tkOperator
Set Bin.Operator = NewOperator(Tk)

Set Tk = New Token
Tk.Code = vbLong
Tk.Kind = tkIntegerNumber
Tk.Text = "+1"

Set Lt = New Literal
Set Lt.Value = Tk
Set Bin.RHS = Lt
Set Mem.Value = Bin
Else
Set Tk = New Token
Tk.Code = vbLong
Tk.Kind = tkIntegerNumber
Tk.Text = "+" & CStr(Count)

Set Lt = New Literal
Set Lt.Value = Tk
Set Mem.Value = Lt
Count = Count + 1
End If

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

Enm.Enumerands.AddKeyValue NameBank(Mem.Id.Name), Mem
SymTab.AddEnumerand Pad_, Enm, Mem
Loop While IsBreak(Token)

Set Pad_.Parent = Nothing
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 Pad_.Entity, Enm.Id.Name

Pad_.Entity.Enums.AddKeyValue NameBank(Enm.Id.Name), Enm
Exit Sub

ErrHandler:
ErrReraise "ParseEnum"
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 = Pad_.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 Pad_.Entity, Dcl.Id.Name

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

Pad_.Entity.Declares.AddKeyValue NameBank(Dcl.Id.Name), Dcl
SymTab.AddDeclare Pad_, Dcl
Exit Sub

ErrHandler:
ErrReraise "ParseDeclare"
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 = Pad_.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 Pad_.Source.Path, CurrParm
Return

ErrHandler:
ErrReraise "ParseParms"
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 Pad_.Entity, Evt.Id.Name
Pad_.Entity.Events.AddKeyValue NameBank(Evt.Id.Name), Evt
Exit Sub

ErrHandler:
ErrReraise "ParseEvent"
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:
ErrReraise "ParseImplements"
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 Pad_.Method = Nothing
SymTab.AddSub Pad_, Proc
Set Pad_.Method = Proc

Name = NameBank(Proc.Id.Name)
CheckDupl Pad_.Entity, Proc.Id.Name
Pad_.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:
ErrReraise "ParseSub"
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 = Pad_.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 Pad_.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 Pad_.Entity, Func.Id.Name
Pad_.Entity.Functions.Add Func, Name

SymTab.AddFunc Pad_, Func
Set Pad_.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:
ErrReraise "ParseFunction"
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 Pad_.Entity, Token, JumpProp:=True

If Pad_.Entity.Properties.Exists(Name) Then
Set Slot = Pad_.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 = Pad_.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
Pad_.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
SymTab.AddProp Pad_, Prop
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:
ErrReraise "ParseProperty"
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
Attrs.Add Attr

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

Set ParseAttributes = Token
Exit Function

ErrHandler:
ErrReraise "ParseAttributes"
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:
ErrReraise "ParseDim"
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)
Set Pad_.Parent = Udt
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
Set Token = SkipLineBreaks
Loop Until Token.IsKeyword(kwEnd)

SymTab.AddType Pad_, Udt
Set Pad_.Parent = Nothing
Set Token = NextToken
If Not Token.IsKeyword(kwType) Then Fail Token, m.RuleEndType, v.Type

Name = NameBank(Udt.Id.Name)
CheckDupl Pad_.Entity, Var.Id.Name
Pad_.Entity.Types.Add Udt, Name
Exit Sub

ErrHandler:
ErrReraise "ParseType"
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 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:
ErrReraise "ParseBody"
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:
ErrReraise "ParseClose"
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:
ErrReraise "ParseContinue"
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:
ErrReraise "ParseDo"
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:
ErrReraise "ParseErase"
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:
ErrReraise "ParseExit"
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:
ErrReraise "ParseFor"
End Function

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

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:
ErrReraise "ParseForEach"
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:
ErrReraise "ParseGet"
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:
ErrReraise "ParseGoSub"
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:
ErrReraise "ParseGoTo"
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:
ErrReraise "ParseIf"
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

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:
ErrReraise "ParseInput"
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:
ErrReraise "ParseLock"
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:
ErrReraise "ParseLSet"
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:
ErrReraise "ParseName"
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:
ErrReraise "ParseOn"
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:
ErrReraise "ParseOpen"
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:
ErrReraise "ParsePrint"
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:
ErrReraise "ParsePut"
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:
ErrReraise "ParseRaiseEvent"
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:
ErrReraise "ParseReDim"
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:
ErrReraise "ParseResume"
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:
ErrReraise "ParseSelect"
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:
ErrReraise "ParseRSet"
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:
ErrReraise "ParseSeek"
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:
ErrReraise "ParseUnlock"
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:
ErrReraise "ParseWhile"
End Sub

Private Function ParseWidth(ByVal Body As KeyedList) As Token
Dim Xp As Expressionist
Dim Stmt As WidthConstruct
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:
ErrReraise "ParseWidth"
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.PinnedObject = Xp.GetStmt(Me, Token)
Set Token = Xp.LastToken
If Stmt.PinnedObject 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:
ErrReraise "ParseWith"
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:
ErrReraise "ParseWrite"
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 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(Pad_, Expr)

CompileConsts.Add Item:=EvaluateDirective(Pad_.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:
ErrReraise "ParseDirective"
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(Pad_.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 Pad_.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(Pad_.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(Pad_.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 = Pad_.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 Pad_.Entity, Var.Id.Name
If Adder.Vars.Exists(Name) Then Fail Token, m.AmbiguousName & Name
Adder.Add Pad_, 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:
ErrReraise "ParseVar"
End Sub

Private Sub Fail(ByVal Token As Token, ByVal Message As String, Optional ByVal Expected As String)
Utils.Fail Pad_.Source.Path, 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

Set Where = Me
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

Op = Conditions(Idx)

Idx = Idx + 1
If Idx > Udx Then Err.Raise 5, TypeName(Me), Msg1

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 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 Project
Option Explicit

Private SourceFiles_ As KeyedList

Public Name As String
Public BuildPath As String

Private Sub Class_Initialize()
Set SourceFiles_ = New KeyedList
Set SourceFiles_.T = NewValidator(TypeName(New SourceFile))
End Sub

Public Property Get SourceFiles() As KeyedList
Set SourceFiles = SourceFiles_
End Property
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
Public EntryIndex As Long

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_Body() As KeyedList
Set IMethod_Body = Body_
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_EntryIndex() As Long
IMethod_EntryIndex = EntryIndex
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 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 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 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 Pad As Pad, ByVal Var As Variable, ByVal Name As String)
If Pad.Entity.Vars.Exists(Name) Then Exit Sub

Vars_.Add Var, Name
Panel_.AddVar Pad.Source.Path, Var, IsReDim:=True
SymTab.AddVar Pad, Var
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 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
GoSub ClassifyNumber

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

Token.Text = "+" & Token.Text
GoSub ClassifyNumber

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

ClassifyNumber:
If Token.Code = 0 Then
Select Case Token.Kind
Case tkIntegerNumber
Select Case Right$(String$(18, "0") & Mid$(Token.Text, 2), 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 + 1
Token.Code = vbDouble

Case Is > 32 + 1
Token.Code = vbLongLong

Case Is > 16 + 1
Token.Code = vbLong

Case Else
Token.Code = vbInteger
End Select

Case tkOctalNumber
Select Case Right$(String(21, "0") & Mid$(Token.Text, 2), 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 + 1
Token.Code = vbDouble

Case Is > 8 + 1
Token.Code = vbLongLong

Case Is > 4 + 1
Token.Code = vbLong

Case Else
Token.Code = vbInteger
End Select

Case tkFloatNumber, tkSciNumber
Token.Code = vbDouble

Case Else
Rem Should not happen
Debug.Assert False
End Select
End If

Return
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 Msg_
Result.Text = Result.Text & "." & FracPart.Text
Result.Kind = tkFloatNumber
Result.Suffix = FracPart.Suffix
Else
UngetChar Ch
End If
End If
End If

Set ReadFloat = Result
End Function

Private Function ReadNumber(ByVal FirstDigit As String) As Token
Dim Ch As String * 1
Dim Sg As String * 1
Dim Result As Token
Dim ExpPart As Token

Set Result = ReadFloat(FirstDigit)

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

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

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

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

Case Else
UngetChar Ch
End Select
End If
End If

Set ReadNumber = Result
End Function

Private Function ReadAmpersand() As Token
Dim Ch As String * 1
Dim Token As Token

Ch = GetChar

Select Case Ch
Case "b", "B"
Set Token = ReadBin
Token.Text = "+" & Token.Text

Case "o", "O"
Set Token = ReadOctal
Token.Text = "+" & Token.Text

Case "h", "H"
Set Token = ReadHexa
Token.Text = "+" & Token.Text

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

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

Set ReadAmpersand = Token
End Function

Private Function ReadBin() As Token
Static Chars As KeyedList

If Chars Is Nothing Then
Set Chars = New KeyedList
Chars.AddKVPairs "0", "0", "1", "1"
End If

Set ReadBin = ReadBOH(Chars, 96, tkBinaryNumber)
End Function

Private Function ReadOctal()
Static Chars As KeyedList

If Chars Is Nothing Then
Set Chars = New KeyedList
Chars.AddKVPairs "0", "0", "1", "1", "2", "2", "3", "3", "4", "4", "5", "5", "6", "6", "7", "7"
End If

Set ReadOctal = ReadBOH(Chars, 32, tkOctalNumber)
End Function

Private Function ReadHexa() As Token
Static Chars As KeyedList

If Chars Is Nothing Then
Set Chars = New KeyedList
Chars.AddKVPairs "0", "0", "1", "1", "2", "2", "3", "3", "4", "4", "5", "5", "6", "6", "7", "7", "8", "8", "9", "9", _
"a", "a", "b", "b", "c", "c", "d", "d", "e", "e", "f", "f", _
"A", "A", "B", "B", "C", "C", "D", "D", "E", "E", "F", "F"
End If

Set ReadHexa = ReadBOH(Chars, 24, tkHexaNumber)
End Function

Private Function ReadHash() As Token
Dim Cp As Integer
Dim Number As Integer
Dim Name As String
Dim Ch As String * 1
Dim Token As Token

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

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

Select Case HashKeyword(Name)
Case kwIf
Rem Not a month name, we have a compiler directive instead.
Set ReadHash = NewToken(tkDirective, Code:=kwIf, Text:=Name)
Exit Function

Case kwElseIf
Rem Not a month name, we have a compiler directive instead.
Set ReadHash = NewToken(tkDirective, Code:=kwElseIf, Text:=Name)
Exit Function

Case kwElse
Rem Not a month name, we have a compiler directive instead.
Set ReadHash = NewToken(tkDirective, Code:=kwElse, Text:=Name)
Exit Function

Case kwEnd
Rem Not a month name, we have a compiler directive instead.
Set ReadHash = NewToken(tkDirective, Code:=kwEnd, Text:=Name)
Exit Function

Case kwConst
Rem Not a month name, we have a compiler directive instead.
Set ReadHash = NewToken(tkDirective, Code:=kwConst, Text:=Name)
Exit Function

Case 0
Fail Msg_

Case Else
Number = ConvertNameToNumber(Name)

If Number = 0 Then
Rem Not a month name, we have a variable file-handle instead.
Rem Hopefully this variable is not named Feb, for instance, otherwise we'll get tricked...
Set ReadHash = NewToken(tkFileHandle, Text:=Name)
Exit Function
End If

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

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

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

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

Rem Date literal must end with a '#'.
Ch = GetChar
If Ch <> "#" Then Fail Msg_

Name = "1899-12-30 " & Name
Set ReadHash = NewToken(tkDateTime, Text:=Name)
Exit Function
End If

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

If Err.Number Then
Rem It is not a date, but a numeric file handle
Rem TODO: Can ReadDate scan more than one character?
On Error GoTo 0
UngetChar Ch
Token.Kind = tkFileHandle
Set ReadHash = Token
Exit Function
End If

On Error GoTo 0
Ch = GetChar

Select Case Ch
Case " "
Rem We may have a date and time literal together.
Set ReadHash = NewToken(tkDateTime, Text:=ReadTime)
If ReadHash.Text = "" Then Fail Msg_
ReadHash.Text = Name & " " & ReadHash.Text

Ch = GetChar
If Ch <> "#" Then Fail Msg_

Case "#"
Rem Literal does not have a time part. Let's add it.
Set ReadHash = NewToken(tkDateTime, Text:=Name & " 00:00:00")

Case Else
Fail Msg_
End Select
End Function

Private Function ReadDate(ByVal FirstNumber As String, ByVal Separator As String) As String
Dim YYYY As Integer
Dim MM As Integer
Dim DD As Integer
Dim Result As String
Dim Ch As String * 1
Dim SecondNumber As Token
Dim ThirdNumber As Token

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

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

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

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

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

Rem Validate year.
If YYYY > 9999 Then Fail Msg_

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

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

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

Case Else
If DD > 31 Then Fail Msg_
End Select

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

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

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

ReadDate = Result
End Function

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

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

Ch = GetChar

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

If Not AtEnd Then
Ch = GetChar

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

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

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

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

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

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

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

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

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

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

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

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

ReadTime = Number
Exit Function

GoneWrong:
Fail Msg_
End Function

Private Function ReadMonthName() As String
Dim Result As String
Dim Ch As String * 1
Dim Prv As String * 1

Do Until AtEnd
Prv = Ch
Ch = GetChar

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

Case "0" To "9"
Rem We safely can assume we read two characters more than needed.
UngetChar Ch
UngetChar Prv
Result = Left$(Result, Len(Result) - 1)
Exit Do

Case Else
Result = Result & Ch
End Select
Loop

ReadMonthName = Result
End Function

Private Function ConvertNameToNumber(ByVal Name As String) As Integer
Dim Count As Integer
Dim Result As Integer
Dim MonthName As Variant
Static MonthNames As Variant

If IsEmpty(MonthNames) Then
MonthNames = Array("January", "February", "March", "April", "May", "June", _
"July", "August", "September", "October", "November", "December")
End If

For Each MonthName In MonthNames
Count = Count + 1

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

ConvertNameToNumber = Result
End Function

Private Function NewToken( _
ByVal Kind As TokenKind, _
Optional ByVal Code As Long, _
Optional ByVal Text As String, _
Optional ByVal Suffix As String = vbNullChar _
) As Token
Set NewToken = New Token

With NewToken
.Text = Text
.Code = Code
.Kind = Kind
.Suffix = Suffix
.Line = RunningLine_
.Column = FrozenColumn_
End With
End Function

Private Function ReadComment(Optional ByVal IsRem As Boolean) As Token
Const MAX_LENGTH = 1013

Dim Count As Integer
Dim Text As String
Dim Ch As String * 1
Dim Buffer As String * MAX_LENGTH

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

Count = Len(Text)
Mid$(Buffer, 1, Count) = Text

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

Count = Count + 1
Mid$(Buffer, Count, 1) = Ch
Loop

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

Private Function ReadInlineComment() As Token
Dim Count As Long
Dim Ch As String * 1
Dim Token As Token

Set Token = NewToken(tkInlineComment)
Count = 1

Do Until AtEnd
Ch = GetChar

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

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

Token.Text = Token.Text & Ch
Loop

Set ReadInlineComment = Token
End Function

Private Sub Class_Terminate()
If File_ <> 0 Then Close #File_
End Sub

Private Function ReadBOH(ByVal AllowedChars As KeyedList, ByVal MaxLength As Integer, ByVal Kind As TokenKind) As Token
Dim Skip As Boolean
Dim Count As Integer
Dim Ch As String * 1
Dim Suffix As String * 1
Dim Buffer As String * 96

Skip = True

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

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

Case "_"
Rem We'll ignore it

Case "0"
If Not Skip Then GoTo 10

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

Skip = False
10 Count = Count + 1
Mid$(Buffer, Count, 1) = Ch
End Select
Loop

If Skip Then
Count = 1
Mid$(Buffer, Count, 1) = "0"
End If

If Count = 0 Then Fail Msg_
Set ReadBOH = NewToken(Kind, , Left$(Buffer, Count), Suffix)
End Function
End Class


Public Class SeekConstruct
Option Explicit
Implements IStmt

Public FileNumber As IExpression
Public Position As IExpression

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


Public Class SelectConstruct
Option Explicit
Implements IStmt

Private Cases_ As KeyedList
Private CaseElse_ As KeyedList

Public Value As IExpression

Private Sub Class_Initialize()
Set Cases_ = New KeyedList
Set Cases_.T = NewValidator(TypeName(New CaseConstruct))

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

Public Property Get Cases() As KeyedList
Set Cases = Cases_
End Property

Public Property Get CaseElse() As KeyedList
Set CaseElse = CaseElse_
End Property

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


Public Class SetConstruct
Option Explicit
Implements IStmt

Public Name As IExpression
Public Value As IExpression

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


Public Class SourceFile
Option Explicit

Private Entities_ As KeyedList

Public Path As String

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

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


Public Class StmtValidator
Option Explicit
Implements IKLValidator

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


Public Class StopConstruct
Option Explicit
Implements IStmt

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


Public Class SubConstruct
Option Explicit
Implements IMethod

Private Parms_ As KeyedList
Private Body_ As KeyedList
Private Attributes_ As KeyedList
Private Consts_ As KeyedList
Private DataType_ As DataType

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

Private Sub Class_Initialize()
Dim Token As Token

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

Set Token = New Token
Token.Kind = tkKeyword
Token.Code = kwVoid

Set DataType_ = New DataType
Set DataType_.Id = NewId(Token)
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_Body() As KeyedList
Set IMethod_Body = Body_
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_EntryIndex() As Long
IMethod_EntryIndex = EntryIndex
End Property

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

Private Property Get IMethod_Kind() As VbCallType
Rem Left intentionally empty
End Property

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


Public Class SubscriptPair
Option Explicit

Private UpperBound_ As IExpression

Public LowerBound As IExpression

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

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


Public Class Symbol
Option Explicit
Implements IExpression
Implements IBindable

Public Value As Token
Public Binding As Long

Private Property Let IBindable_Binding(ByVal NewValue As Long)
IBindable_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 = ekSymbol
End Property
End Class


Public Class SymTab
Option Explicit

Public Enum EntryLevel
elNone ' 0
elMethod ' 1
elEntity ' 2
elCustom ' 3
elGlobal ' 4
End Enum

Public Enum EntryFlags
efNormal ' 0
efIsType ' 1
efStartOfPath ' 2
efNextInPath = 4
efReadable = 8
efWritable = 16
End Enum

Public Enum EntryType
etIntrinsic
etModule
etClass
etConst
etVar
etSub
etFunc
etProp
etDecl
etParm
etEnum
etEnumerand
etType
End Enum

Private Type Entry
Index As Long
Parent As Long
Kind As EntryType
Name As Long
Meta As Long
Level As EntryLevel
Flags As EntryFlags
Obj As Object
End Type

Private Index_ As Long
Private Capacity_ As Long
Private Entries_() As Entry

Private Sub Class_Initialize()
Capacity_ = 8192
ReDim Entries_(1 To Capacity_)

AddBuiltin kwBoolean
AddBuiltin kwByte
AddBuiltin kwInteger
AddBuiltin kwLong
AddBuiltin kwLongPtr
AddBuiltin kwLongLong
AddBuiltin kwCurrency
AddBuiltin cxDecimal
AddBuiltin kwSingle
AddBuiltin kwDouble
AddBuiltin kwDate
AddBuiltin kwString
AddBuiltin cxObject
AddBuiltin kwVariant
End Sub

Private Sub AddBuiltin(ByVal Code As Long)
Dim Current As Entry
Dim Token As Token

IncrementIndex

With Current
.Index = Index_
.Kind = etIntrinsic
.Name = Code
.Level = elCustom
.Flags = efIsType

Set Token = New Token
Token.Code = Code
Token.Kind = tkKeyword
Set .Obj = Token
End With

Entries_(Index_) = Current
End Sub

Private Sub IncrementIndex()
Index_ = Index_ + 1

If Index_ > Capacity_ Then
Capacity_ = Capacity_ * 2
ReDim Preserve Entries_(1 To Capacity_)
End If
End Sub

Public Sub AddEntity(ByVal Pad As Pad, ByVal Entity As Entity)
Dim Current As Entry

IncrementIndex
Entity.EntryIndex = Index_

With Entity
Current.Index = Index_
'If Not .Id.Project Is Nothing Then Current.NS = .Id.Project.Code
Current.Kind = IIf(Entity.IsClass, etClass, etModule)
Current.Name = .Id.Name.Code
If .StdLib Then Current.Level = elGlobal Else Current.Level = elCustom
If .IsClass Then Current.Flags = efIsType Else Current.Flags = efStartOfPath
End With

Set Current.Obj = Entity
Entries_(Index_) = Current
Set Pad.Entity = Entity
End Sub

Public Sub AddConst(ByVal Pad As Pad, ByVal Constant As ConstConstruct)
Dim Current As Entry

IncrementIndex
Constant.EntryIndex = Index_

With Current
.Index = Index_
If Pad.Method Is Nothing Then .Parent = Pad.Entity.EntryIndex Else .Parent = Pad.Method.EntryIndex
.Kind = etConst
.Name = Constant.Id.Name.Code
If Not TypeOf Constant.DataType Is ConstDataType Then .Meta = -Constant.DataType.Id.Name.Code

If Pad.Method Is Nothing Then
If Constant.Access = acPublic Or Constant.Access = acFriend Then
.Level = elCustom
Else
.Level = elEntity
End If
End If

.Flags = efStartOfPath Or efNextInPath Or efReadable
Set .Obj = Constant
End With

Entries_(Index_) = Current
End Sub

Public Sub AddVar(ByVal Pad As Pad, ByVal Var As Variable)
Dim Current As Entry

IncrementIndex
Var.EntryIndex = Index_

With Current
.Index = Index_

If Not Pad.Parent Is Nothing Then
.Parent = Pad.Parent.EntryIndex

ElseIf Pad.Method Is Nothing Then
.Parent = Pad.Entity.EntryIndex

Else
.Parent = Pad.Method.EntryIndex
End If

.Kind = etVar
.Name = Var.Id.Name.Code
.Meta = -Var.DataType.Id.Name.Code

If Pad.Parent Is Nothing Then
If Pad.Entity.IsClass Then
If Pad.Method Is Nothing Then
.Level = elEntity
Else
.Level = elMethod
End If
Else
If Var.Access = acFriend Or Var.Access = acPublic Then
.Level = elCustom
Else
.Level = elEntity
End If
End If
End If

.Flags = efStartOfPath Or efNextInPath Or efReadable Or efWritable
Set .Obj = Var
End With

Entries_(Index_) = Current
End Sub

Public Sub AddSub(ByVal Pad As Pad, ByVal Proc As SubConstruct)
Dim Current As Entry

IncrementIndex
Proc.EntryIndex = Index_

With Current
.Index = Index_
.Parent = Pad.Entity.EntryIndex
.Kind = etSub
.Name = Proc.Id.Name.Code
.Level = elCustom
.Flags = efStartOfPath Or efNextInPath
Set .Obj = Proc
End With

Entries_(Index_) = Current
Set Pad.Method = Proc
AddParms Pad, Proc.Parameters
End Sub

Public Sub AddFunc(ByVal Pad As Pad, ByVal Func As FunctionConstruct)
Dim Current As Entry

IncrementIndex
Func.EntryIndex = Index_

With Current
.Index = Index_
.Parent = Pad.Entity.EntryIndex
.Kind = etFunc
.Name = Func.Id.Name.Code
.Meta = -Func.DataType.Id.Name.Code
If Pad.Entity.StdLib Then .Level = elGlobal Else .Level = elCustom
.Flags = efStartOfPath Or efNextInPath Or efReadable
Set .Obj = Func
End With

Entries_(Index_) = Current
Set Pad.Method = Func
AddParms Pad, Func.Parameters
End Sub

Public Sub AddProp(ByVal Pad As Pad, ByVal Prop As PropertyConstruct)
Dim Current As Entry

IncrementIndex
Prop.EntryIndex = Index_

With Current
.Index = Index_
.Parent = Pad.Entity.EntryIndex
.Kind = etProp
.Name = Prop.Id.Name.Code
If Prop.Kind = VbGet Then .Meta = -Prop.DataType.Id.Name.Code
If Pad.Entity.StdLib Then .Level = elGlobal Else .Level = elCustom
.Flags = efStartOfPath Or efNextInPath
If Prop.Kind = VbGet Then .Flags = .Flags Or 8 Else .Flags = .Flags Or 16
Set .Obj = Prop
End With

Entries_(Index_) = Current
Set Pad.Method = Prop
AddParms Pad, Prop.Parameters
End Sub

Public Sub AddDeclare(ByVal Pad As Pad, ByVal Dcl As DeclareConstruct)
Dim Current As Entry

IncrementIndex
Dcl.EntryIndex = Index_

With Current
.Index = Index_
.Parent = Pad.Entity.EntryIndex
.Kind = etDecl
.Name = Dcl.Id.Name.Code
If Not Dcl.IsSub Then .Meta = -Dcl.DataType.Id.Name.Code

If Pad.Entity.IsClass Then
.Level = elEntity

ElseIf Dcl.Access = acFriend Or Dcl.Access = acPublic Then
.Level = elCustom

Else
.Level = elEntity
End If

.Flags = efStartOfPath Or efNextInPath
If Not Dcl.IsSub Then .Flags = .Flags Or 8
Set .Obj = Dcl
End With

Entries_(Index_) = Current
Rem HACK: Declare is not an IMethod
Dim Proc As SubConstruct
Set Proc = New SubConstruct
Set Proc.Id = Dcl.Id
Set Pad.Method = Proc
AddParms Pad, Dcl.Parameters
End Sub

Private Sub AddParms(ByVal Pad As Pad, ByVal Parms As KeyedList)
Dim Current As Entry
Dim Parm As Parameter

For Each Parm In Parms
IncrementIndex
Parm.EntryIndex = Index_

With Current
.Index = Index_
.Parent = Pad.Method.EntryIndex
.Kind = etParm
.Name = Parm.Id.Name.Code
.Meta = -Parm.DataType.Id.Name.Code
.Level = elMethod
.Flags = efStartOfPath Or efReadable And efWritable
Set .Obj = Parm
End With

Entries_(Index_) = Current
Next
End Sub

Public Sub AddEnum(ByVal Pad As Pad, ByVal Enm As EnumConstruct)
Dim Current As Entry
Dim Mem As EnumerandConstruct

IncrementIndex
Enm.EntryIndex = Index_

With Current
.Index = Index_
.Parent = Pad.Entity.EntryIndex
.Kind = etEnum
.Name = Enm.Id.Name.Code
If Enm.Access = acFriend Or Enm.Access = acPublic Then .Level = elCustom Else .Level = elEntity
.Flags = efIsType Or efStartOfPath Or efNextInPath
Set .Obj = Enm
End With

Entries_(Index_) = Current
Set Pad.Parent = Enm

For Each Mem In Enm.Enumerands
AddEnumerand Pad, Enm, Mem
Next

Set Pad.Parent = Nothing
End Sub

Public Sub AddEnumerand(ByVal Pad As Pad, ByVal Enm As EnumConstruct, ByVal Mem As EnumerandConstruct)
Dim Current As Entry

IncrementIndex
Mem.EntryIndex = Index_

With Current
.Index = Index_
.Parent = Enm.EntryIndex
.Kind = etEnumerand
.Name = Mem.Id.Name.Code
.Meta = 4 'vbLong

If Enm.Access = acFriend Or Enm.Access = acPublic Then
.Level = elCustom
Else
.Level = elEntity
End If

.Flags = efStartOfPath Or efNextInPath Or efReadable
Set .Obj = Mem
End With

Entries_(Index_) = Current
End Sub

Public Sub AddType(ByVal Pad As Pad, ByVal Udt As TypeConstruct)
Dim Current As Entry

IncrementIndex
Udt.EntryIndex = Index_

With Current
.Index = Index_
.Parent = Pad.Entity.EntryIndex
.Kind = etType
.Name = Udt.Id.Name.Code

If Udt.Access = acFriend Or Udt.Access = acPublic Then
.Level = elCustom
Else
.Level = elEntity
End If

.Flags = efIsType
Set .Obj = Udt
End With

Entries_(Index_) = Current
Set Pad.Parent = Udt
End Sub

Public Sub ResolveSymbols()
Dim Idx As Long
Dim Cnt As ConstConstruct
Dim Entry As Entry

On Error GoTo ErrHandler

For Idx = 1 To Index_
Entry = Entries_(Idx)

If Entry.Kind = etConst Then
Set Cnt = Entry.Obj
If TypeOf Cnt.DataType Is ConstDataType Then Entry.Meta = -Cnt.DataType.Id.Name.Code
End If

If Entry.Meta < 0 Then Entries_(Idx).Meta = FindDataType(Entry)
Next

Exit Sub

ErrHandler:
ErrReraise "ResolveSymbols"
End Sub

Private Function FindDataType(ByRef Entry As Entry) As Long
Dim Idx As Long
Dim Found As Entry
Dim Result As Entry

For Idx = 1 To Index_
Found = Entries_(Idx)

With Found
Do
If .Name <> -Entry.Meta Then Exit Do
If (.Flags And efIsType) = 0 Then Exit Do

If Result.Index = 0 Then
Result = Found

Else
If Entry.Parent <> 0 And .Index = Entry.Parent Then Result = Found
If Result.Level > .Level Then Result = Found
End If
Loop While False
End With
Next

FindDataType = Result.Index
End Function

Friend Property Let Meta(ByVal Index As Long, ByVal Value As VbVarType)
Entries_(Index).Meta = -VtToKw(Value)
End Property

Public Property Get MetaOf(ByVal Index As Long) As Long
MetaOf = Entries_(Index).Meta
End Property

Public Property Get KindOf(ByVal Index As Long) As EntryType
KindOf = Entries_(Index).Kind
End Property

Public Property Get NameOf(ByVal Index As Long) As Long
NameOf = Entries_(Index).Name
End Property

Public Property Get ObjOf(ByVal Index As Long) As Object
Set ObjOf = Entries_(Index).Obj
End Property

Public Function FindLhs(ByVal Pad As Pad, ByVal Code As Long, ByVal IsLastOrOnly As Boolean) As Long
Dim Idx As Long
Dim Found As Entry
Dim Current As Entry

Rem TODO: How to downgrade [Sub], [Property], or [Function] from [Global] to [Custom]?
On Error GoTo ErrHandler

For Idx = 1 To Index_
Do
Current = Entries_(Idx)
If Current.Name <> Code Then Exit Do

If IsLhsRetVal(Current, IsLastOrOnly) Then Found = Current: Exit For

If IsLhsLocalVarOrParm(Pad, Current, IsLastOrOnly) Then Found = Current: Exit For
If IsLhsEntyVar(Pad, Current, IsLastOrOnly) Then Found = Current: Exit For
If IsLhsGlobalVar(Pad, Current, IsLastOrOnly) Then Found = Current: Exit For

If IsLhsEntyFunc(Pad, Current, IsLastOrOnly) Then Found = Current: Exit For
If IsLhsGlobalFunc(Current, IsLastOrOnly) Then Found = Current: Exit For

If IsLhsEntyProp(Pad, Current, IsLastOrOnly) Then Found = Current: Exit For
If IsLhsGlobalProp(Current, IsLastOrOnly) Then Found = Current: Exit For
Loop While False
Next

FindLhs = Found.Index
Exit Function

ErrHandler:
ErrReraise "FindLhs"
End Function

Public Function FindRhs(ByVal Pad As Pad, ByVal Code As Long, ByVal IsLastOrOnly As Boolean) As Long
Dim Idx As Long
Dim Found As Entry
Dim Current As Entry

Rem TODO: How to downgrade [Sub], [Property], or [Function] from [Global] to [Custom]?
On Error GoTo ErrHandler

For Idx = 1 To Index_
Do
Current = Entries_(Idx)
If Current.Name <> Code Then Exit Do

If IsRhsRetVal(Current, IsLastOrOnly) Then Found = Current: Exit For

If IsLocalConst(Pad, Current) Then Found = Current: Exit For
If IsEntyConst(Pad, Current) Then Found = Current: Exit For
If IsGlobalConst(Current) Then Found = Current: Exit For

If IsEntyEnum(Pad, Current) Then Found = Current: Exit For
If IsGlobalEnum(Pad, Current) Then Found = Current: Exit For

If IsRhsLocalVarOrParm(Pad, Current, IsLastOrOnly) Then Found = Current: Exit For
If IsRhsEntyVar(Pad, Current, IsLastOrOnly) Then Found = Current: Exit For
If IsRhsGlobalVar(Current, IsLastOrOnly) Then Found = Current: Exit For

If IsRhsEntyFunc(Pad, Current, IsLastOrOnly) Then Found = Current: Exit For
If IsRhsGlobalFunc(Current, IsLastOrOnly) Then Found = Current: Exit For

If IsRhsEntyProp(Pad, Current, IsLastOrOnly) Then Found = Current: Exit For
If IsRhsGlobalProp(Current, IsLastOrOnly) Then Found = Current: Exit For
Loop While False
Next

FindRhs = Found.Index
Exit Function

ErrHandler:
ErrReraise "FindRhs"
Resume
End Function

Private Function IsLhsRetVal(ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
Rem TODO: IsLastOrOnly is not enough:
Rem MyObj.MyFunc = ...... [KO] 'It is legal, but odd and probably uncommon.
Rem MyFunc() = .......... [KO]
Rem MyFunc.MyMember = ... [OK]
If Not IsLastOrOnly Then Exit Function
If Current.Meta = 0 Then Exit Function 'Must have or produce a data type
If Current.Kind <> etFunc And Current.Kind <> etProp Then Exit Function
IsLhsRetVal = True
End Function

Private Function IsRhsRetVal(ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
If Not IsLastOrOnly Then Exit Function
'If Current.Meta = 0 Then Exit Function 'Must have or produce a data type
If Current.Kind <> etFunc And Current.Kind <> etProp Then Exit Function
Rem TODO: Cannot have ([...]) after it.
IsRhsRetVal = True
End Function

Private Function IsLhsLocalVarOrParm(ByVal Pad As Pad, ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
IsLhsLocalVarOrParm = IsLocalVarOrParm(Pad, Current, efWritable, IsLastOrOnly)
End Function

Private Function IsRhsLocalVarOrParm(ByVal Pad As Pad, ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
IsRhsLocalVarOrParm = IsLocalVarOrParm(Pad, Current, efReadable, IsLastOrOnly)
End Function

Private Function IsLocalVarOrParm(ByVal Pad As Pad, ByRef Current As Entry, ByVal Flag As Long, ByVal IsLastOrOnly As Boolean) As Boolean
Dim Mthd As Long

If Current.Kind <> etVar Then Exit Function
If Current.Level <> elMethod Then Exit Function
If Not Pad.Method Is Nothing Then Mthd = Pad.Method.Id.Name.Code
If Current.Parent <> Mthd Then Exit Function
If (Current.Flags And efStartOfPath) = 0 Then Exit Function
If IsLastOrOnly And (Current.Flags And Flag) = 0 Then Exit Function
IsLocalVarOrParm = True
End Function

Private Function IsLhsEntyVar(ByVal Pad As Pad, ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
IsLhsEntyVar = IsEntyVar(Pad, Current, efWritable, IsLastOrOnly)
End Function

Private Function IsRhsEntyVar(ByVal Pad As Pad, ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
IsRhsEntyVar = IsEntyVar(Pad, Current, efReadable, IsLastOrOnly)
End Function

Private Function IsEntyVar(Pad As Pad, ByRef Current As Entry, ByVal Flag As Long, ByVal IsLastOrOnly As Boolean) As Boolean
If Current.Kind <> etVar Then Exit Function
If Current.Level <> elEntity Then Exit Function
If Current.Parent <> Pad.Entity.Id.Name.Code Then Exit Function
If (Current.Flags And efStartOfPath) = 0 Then Exit Function
If IsLastOrOnly And (Current.Flags And Flag) = 0 Then Exit Function
IsEntyVar = True
End Function

Private Function IsLhsGlobalVar(ByVal Pad As Pad, ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
IsLhsGlobalVar = IsGlobalVar(Current, efWritable, IsLastOrOnly)
End Function

Private Function IsRhsGlobalVar(ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
IsRhsGlobalVar = IsGlobalVar(Current, efReadable, IsLastOrOnly)
End Function

Private Function IsGlobalVar(ByRef Current As Entry, ByVal Flag As Long, ByVal IsLastOrOnly As Boolean) As Boolean
If Current.Kind <> etVar Then Exit Function
If (Current.Flags And efStartOfPath) = 0 Then Exit Function
If IsLastOrOnly And (Current.Flags And Flag) = 0 Then Exit Function
If Current.Kind <> etVar Then Exit Function
IsGlobalVar = True
End Function

Private Function IsLhsEntyFunc(ByVal Pad As Pad, ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
Dim IsClassOrType As Boolean

If IsLastOrOnly Then Exit Function
If Current.Kind <> etFunc Then Exit Function
If Current.Level <> elEntity Then Exit Function
If Current.Parent <> Pad.Entity.Id.Name.Code Then Exit Function
If Current.Meta = 0 Then Exit Function
IsClassOrType = Entries_(Current.Meta).Kind = etClass
If Not IsClassOrType Then IsClassOrType = TypeOf Entries_(Current.Meta) Is TypeConstruct
IsLhsEntyFunc = IsClassOrType
End Function

Rem Can be used as [Next In Path] too.
Private Function IsRhsEntyFunc(ByVal Pad As Pad, ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
Dim IsClassOrType As Boolean

If Current.Kind <> etFunc Then Exit Function
If Current.Level <> elEntity Then Exit Function
If Current.Parent <> Pad.Entity.Id.Name.Code Then Exit Function
If Current.Meta = 0 Then Exit Function

If IsLastOrOnly Then
IsRhsEntyFunc = True
Else
IsClassOrType = Entries_(Current.Meta).Kind = etClass
If Not IsClassOrType Then IsClassOrType = TypeOf Entries_(Current.Meta) Is TypeConstruct
IsRhsEntyFunc = IsClassOrType
End If
End Function

Private Function IsLhsGlobalFunc(ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
Dim IsClassOrType As Boolean

If IsLastOrOnly Then Exit Function
If Current.Kind <> etFunc Then Exit Function
If Current.Level <= elEntity Then Exit Function
If Current.Meta = 0 Then Exit Function
IsClassOrType = Entries_(Current.Meta).Kind = etClass
If Not IsClassOrType Then IsClassOrType = Entries_(Current.Meta).Kind = etType
IsLhsGlobalFunc = IsClassOrType
End Function

Private Function IsRhsGlobalFunc(ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
Dim IsClassOrType As Boolean

If IsLastOrOnly Then Exit Function
If Current.Kind <> etFunc Then Exit Function
If Current.Level <= elEntity Then Exit Function
If Current.Meta = 0 Then Exit Function

If IsLastOrOnly Then
IsRhsGlobalFunc = True
Else
IsClassOrType = Entries_(Current.Meta).Kind = etClass
If Not IsClassOrType Then IsClassOrType = TypeOf Entries_(Current.Meta) Is TypeConstruct
IsRhsGlobalFunc = IsClassOrType
End If
End Function

Private Function IsLhsEntyProp(ByVal Pad As Pad, ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
Dim IsClassOrType As Boolean
Dim Prop As PropertyConstruct

If Current.Level <> elEntity Then Exit Function
If Current.Parent <> Pad.Entity.Id.Name.Code Then Exit Function
If Current.Kind <> etProp Then Exit Function
Set Prop = Current.Obj

If IsLastOrOnly Then
IsLhsEntyProp = Prop.Kind <> VbGet
Else
If Prop.Kind <> VbGet Then Exit Function
If Current.Meta = 0 Then Exit Function
IsClassOrType = Entries_(Current.Meta).Kind = etClass
If Not IsClassOrType Then IsClassOrType = Entries_(Current.Meta).Kind = etType
IsLhsEntyProp = IsClassOrType
End If
End Function

Private Function IsRhsEntyProp(ByVal Pad As Pad, ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
Dim IsClassOrType As Boolean
Dim Prop As PropertyConstruct

If Current.Level <> elEntity Then Exit Function
If Current.Parent <> Pad.Entity.Id.Name.Code Then Exit Function
If Current.Kind <> etProp Then Exit Function
Set Prop = Current.Obj

If IsLastOrOnly Then
IsRhsEntyProp = Prop.Kind = VbGet
Else
If Prop.Kind <> VbGet Then Exit Function
If Current.Meta = 0 Then Exit Function
IsClassOrType = Entries_(Current.Meta).Kind = etClass
If Not IsClassOrType Then IsClassOrType = Entries_(Current.Meta).Kind = etType
IsRhsEntyProp = IsClassOrType
End If
End Function

Private Function IsLhsGlobalProp(ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
Dim IsClassOrType As Boolean
Dim Prop As PropertyConstruct

If Current.Kind <> etProp Then Exit Function
Set Prop = Current.Obj

If IsLastOrOnly Then
IsLhsGlobalProp = Prop.Kind <> VbGet
Else
If Prop.Kind <> VbGet Then Exit Function
If Current.Meta = 0 Then Exit Function
IsClassOrType = Entries_(Current.Meta).Kind = etClass
If Not IsClassOrType Then IsClassOrType = Entries_(Current.Meta).Kind = etType
IsLhsGlobalProp = IsClassOrType
End If
End Function

Private Function IsRhsGlobalProp(ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
Dim IsClassOrType As Boolean
Dim Prop As PropertyConstruct

If Current.Kind <> etProp Then Exit Function
Set Prop = Current.Obj

If IsRhsGlobalProp Then
IsRhsGlobalProp = Prop.Kind = VbGet
Else
If Prop.Kind <> VbGet Then Exit Function
If Current.Meta = 0 Then Exit Function
IsClassOrType = Entries_(Current.Meta).Kind = etClass
If Not IsClassOrType Then IsClassOrType = Entries_(Current.Meta).Kind = etType
IsRhsGlobalProp = IsClassOrType
End If
End Function

Private Function IsModule(ByRef Current As Entry, ByVal IsLastOrOnly As Boolean) As Boolean
If IsLastOrOnly Then Exit Function
IsModule = Current.Kind = etModule
End Function

Private Function IsLocalConst(ByVal Pad As Pad, ByRef Current As Entry) As Boolean
Dim Mthd As Long

If Current.Kind <> etConst Then Exit Function
If Not Pad.Method Is Nothing Then Mthd = Pad.Method.Id.Name.Code
IsLocalConst = Current.Parent = Mthd And Current.Level = elMethod
End Function

Private Function IsEntyConst(ByVal Pad As Pad, ByRef Current As Entry) As Boolean
If Current.Kind <> etConst Then Exit Function
If Entries_(Current.Parent).Name <> Pad.Entity.Id.Name.Code Then Exit Function
IsEntyConst = Current.Level = elEntity
End Function

Private Function IsGlobalConst(ByRef Current As Entry) As Boolean
If Current.Kind <> etConst Then Exit Function
IsGlobalConst = Current.Level >= elCustom
End Function

Private Function IsEntyEnum(ByVal Pad As Pad, ByRef Current As Entry) As Boolean
If Current.Kind <> etEnumerand Then Exit Function
If Entries_(Current.Parent).Parent <> Pad.Entity.Id.Name.Code Then Exit Function
IsEntyEnum = Current.Level >= elMethod
End Function

Private Function IsGlobalEnum(ByVal Pad As Pad, ByRef Current As Entry) As Boolean
If Current.Kind <> etEnumerand Then Exit Function
IsGlobalEnum = Current.Level >= elMethod
End Function
End Class


Public Class Token
Option Explicit

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

Public Code As Long
Public Line As Long
Public Column As Long
Public Spaces As Long
Public Text As String
Public Suffix As String
Public Kind As TokenKind

Private Sub Class_Initialize()
Text = " "
Suffix = vbNullChar
End Sub

Public Function IsKeyword(ByVal Code As Long) As Boolean
IsKeyword = Kind = tkKeyword And Me.Code = Code
End Function

Public Function IsOperator(ByVal Code As Long) As Boolean
IsOperator = Kind = tkOperator And Me.Code = Code
End Function

Public Function IsId(ByVal Code As Long, Optional ByVal CanHaveSuffix As Boolean) As Boolean
If Not CanHaveSuffix And Suffix <> vbNullChar Then Exit Function

Select Case Kind
Case tkIdentifier, tkEscapedIdentifier, tkCrazyIdentifier
IsId = Me.Code = Code
End Select
End Function
End Class


Public Class TupleConstruct
Option Explicit
Implements IExpression

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

Public Static Property Get Elements() As KeyedList
Dim Hidden As New KeyedList
Set Elements = Hidden
End Property
End Class


Public Class TypeConstruct
Option Explicit

Private Members_ As KeyedList

Public Access As Accessibility
Public Id As Identifier
Public EntryIndex As Long

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

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


Public Class UnaryExpression
Option Explicit
Implements IExpression

Public Operator As Operator
Public Value As IExpression

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


Public Class UnlockConstruct
Option Explicit
Implements IStmt

Public FileNumber As IExpression
Public RecordRange As IExpression

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


Public Class Variable
Option Explicit
Implements IStmt

Private Subscripts_ As KeyedList

Public IsStatic As Boolean
Public HasWithEvents As Boolean
Public HasNew As Boolean
Public IsDefault As Boolean