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

Let's build a transpiler! Part 32

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

So far I have been testing poorly our transpiler code.
This is because once code is parsed and transformed into a graph of objects, it is hard to verify it.
That's why we will start to "undo" the graph and produce VB code again.

Risking a bit of over-engineering, we will create an interface a class - ITextBuilder - to collect the code we will generate.
Then another class - FileTextBuilder - will implement ITextBuilder and save the text into a file.
A third class - Reverter - will revert the object graph to VB code.

While coding them, I needed to recover some tokens' names outside the Scanner class, that's the one that has the NameOf method.
Even if we'd expose it to the external world making NameOf Public, we would need to pass Scanner along to other classes and I don't want to do that.

So, we'll create a fourth class - NameBank - moving the code related to tokens' names from Scanner to it.

Let's go:

Public Class NameBanck
Option Explicit

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

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

Set Ids_ = New KeyedList
Set Ids_.T = NewValidator("String")
Ids_.CompareMode = vbTextCompare

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

Rem Keyword order must follow the Enum's one.
Values = Array(vAny, vAs, vAttribute, vBoolean, vByRef, vByte, vByVal, vCall, vCase, vCDecl, vCircle, _
vClass, vClose, vConst, vContinue, vCurrency, vDate, vDebug, vDeclare, vDefault, vDefBool, vDefByte, _
vDefCur, vDefDate, vDefDbl, vDefDec, vDefInt, vDefLng, vDefLngLng, vDefLngPtr, vDefObj, vDefSng, vDefStr, _
vDefVar, vDim, vDo, vDouble, vEach, vElse, vElseIf, vEmpty, vEnd, vEndIf, vEnum, vErase, vEvent, vExit, vFalse, _
vFor, vFriend, vFunction, vGet, vGlobal, vGoSub, vGoTo, vIf, vImplements, vIn, vInput, vInteger, _
vIterator, vLet, vLong, vLongLong, vLongPtr, vLoop, vLSet, vMe, vModule, vNext, vNothing, vNull, vOn, vOpen, _
vOption, vOptional, vParamArray, vPreserve, vPrint, vPrivate, vPSet, vPublic, vPut, vRaiseEvent, _
vReDim, vRem, vResume, vReturn, vRSet, vScale, vSeek, vSelect, vSet, vSingle, vStatic, vStop, vString, vSub, _
vThen, vTo, vTrue, vType, vUnlock, vUntil, vVariant, vVoid, vWend, vWhile, vWith, vWithEvents, vWrite)

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

Keywords_.ReadOnly = True

Set Contextuals_ = New KeyedList
Set Contextuals_.T = NewValidator("String")
Contextuals_.CompareMode = vbTextCompare
Values = Array(vAccess, vAlias, vAppend, vBase, vBinary, vCompare, vDecimal, vError, vExplicit, vLen, vLib, vLine, _
vLock, vName, vObject, vOutput, vProperty, vPtrSafe, vRandom, vRead, vReset, vShared, vSpc, vStep, vTab, vText, vWidth)

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

Contextuals_.ReadOnly = True

Set Operators_ = New KeyedList
Set Operators_.T = NewValidator("String")
Operators_.CompareMode = vbTextCompare
Rem Operator order must follow the Enum's one.
Values = Array(vAddressOf, vAndAlso, vByVal, vIs, vIsNot, vLike, vNew, vNot, vOrElse, vTo, vTypeOf, _
"~+", "~-", "<", "<=", "=", ">=", ">", "<>", ":=", "~.", "~!", ".", "!", _
vAnd, vEqv, vImp, vMod, vOr, vXor, "+", "-", "*", "/", "\", "^", "<<", ">>", ">>>", "&", _
vAnd & "=", vEqv & "=", vImp & "=", vMod & "=", vOr & "=", vXor & "=", "+=", "-=", "*=", _
"/=", "\=", "^=", "<<=", ">>=", ">>>=", "&=", "")

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

Operators_.ReadOnly = True
End Sub

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

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

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

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

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

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

Case Else
If Token.Code <= Keywords_.Count + Contextuals_.Count Then
Item = Contextuals_(Token.Code - Keywords_.Count)
Else
Item = Ids_(Token.Code - Keywords_.Count - Contextuals_.Count)
End If
End Select
End Function
End Class
We'll have a variable of it in Globals module:

Public NameBank As New NameBank
In doing that, we need to change every NameOf(...) or Parser.NameOf(...) to NameBank(...).

Here it is ITextBuilder:

Public Class ITextBuilder
Option Explicit

Private Sub Class_Initialize()
Err.Raise 5
End Sub
Public Sub Append(ByVal Text As String)
End Sub

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

Public Sub Indent()
End Sub

Public Sub Deindent()
End Sub
End Class
And FileTextBuilder implementing it:

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
It will manage indenting and unindenting the code.
Here is Reverter:

Public Class Reverter
Option Explicit

Public Builder As ITextBuilder

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

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

Private Sub EmitEntity(ByVal Entity As Entity)
Dim Sep As Boolean
Dim Count As Integer
Dim Def As DefType
Dim Var As Variable
Dim Slt As PropertySlot
Dim Prc As SubConstruct
Dim Typ As TypeConstruct
Dim Enm As EnumConstruct
Dim Evt As EventConstruct
Dim Cnt As ConstConstruct
Dim Dcl As DeclareConstruct
Dim Fnc As FunctionConstruct
Dim Prp As PropertyConstruct
Dim Ipl As ImplementsConstruct

With Builder
EmitAccess Entity.Accessibility
.Append IIf(Entity.IsClass, "Class ", "Module ")
EmitId Entity.Id
.AppendLn
.Indent

.Append "Option Base "
.AppendLn Entity.OptionBase

.Append "Option Compare "
.AppendLn IIf(Entity.OptionCompare = vbBinaryCompare, "Binary", "Text")

If Entity.OptionExplicit Then .AppendLn "Option Explicit"
.AppendLn

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

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

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

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

For Each Typ In Entity.Types
EmitType Typ
.AppendLn

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

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

For Each Var In Entity.Vars
EmitDim Var
.AppendLn
Sep = True
Next

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

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

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

For Each Dcl In Entity.Declares
EmitDeclare Dcl
.AppendLn
Sep = True
Next

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

Count = 0

For Each Enm In Entity.Enums
EmitEnum Enm
.AppendLn

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

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

Count = 0

For Each Fnc In Entity.Functions
EmitAccess Fnc.Access
If Fnc.IsStatic Then .Append "Static "
If Fnc.IsDefault Then .Append "Default "
If Fnc.IsIterator Then .Append "Iterator "
.Append "Function "
EmitId Fnc.Id
EmitParams Fnc.Parameters
.Append " As "
EmitDataType Fnc.DataType
.AppendLn
.Indent
EmitBody Fnc.Body
.Deindent
.AppendLn "End Function"

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

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

Count = 0

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

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

Count = 0

For Each Slt In Entity.Properties
If Slt.Exists(VbGet) Then
Set Prp = Slt(VbGet)
EmitAccess Prp.Access
If Prp.IsStatic Then .Append "Static "
If Prp.IsDefault Then .Append "Default "

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

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

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

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

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

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

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

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

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

Count = Count + 1
If Count <> Entity.Properties.Count Then .AppendLn
Next

.Deindent
.Append "End "
.AppendLn IIf(Entity.IsClass, "Class", "Module")
End With
End Sub

Private Sub EmitAccess(ByVal Access As Accessibility)
Select Case Access
Case Accessibility.acPublic
Builder.Append "Public "

Case Accessibility.acPrivate
Builder.Append "Private "

Case Accessibility.acFriend
Builder.Append "Friend "
End Select
End Sub

Private Sub EmitImplements(ByVal Ipl As ImplementsConstruct)
Builder.Append "Implements "
EmitId Ipl.Id
End Sub

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

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

EmitToken Id.Name
End Sub

Private Sub EmitParams(ByVal Params As KeyedList)
Dim Idx As Integer
Dim Parm As Parameter

Builder.Append "("

For Idx = 1 To Params.Count
Set Parm = Params(Idx)

If Parm.IsOptional Then
Builder.Append "Optional "

ElseIf Parm.IsParamArray Then
Builder.Append "ParamArray "
End If

If Not Parm.IsParamArray Then
Builder.Append IIf(Parm.IsByVal, "ByVal ", "ByRef ")
End If

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

Builder.Append " As "
EmitDataType Parm.DataType

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

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

Builder.Append ")"
End Sub

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

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

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

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

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

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

Builder.AppendLn
Next

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

Private Sub EmitSubscripts(ByVal Subscripts As KeyedList)
Dim Idx As Integer
Dim Pair As SubscriptPair

If Subscripts.Count = 0 Then Exit Sub

Builder.Append "("

For Idx = 1 To Subscripts.Count
Set Pair = Subscripts(Idx)

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

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

Builder.Append ")"
End Sub

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

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

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

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

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

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

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

EmitParams Dcl.Parameters

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

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

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

For Each Mem In Enm.Enumerands
EmitId Mem.Id

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

Builder.AppendLn
Next

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

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

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

Case ekSymbol
Set Sym = Expr
EmitToken Sym.Value

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

Case ekTuple
Set Tup = Expr

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

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

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

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

If Par Then Builder.Append ")"

Case ekIndexer
EmitCall Expr
End Select
End Sub

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

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

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

Case snClose
EmitClose Stmt

Case snConst
EmitConst Stmt

Case snContinue
EmitContinue Stmt

Case snDebug
EmitDebug Stmt

Case snDim
EmitDim Stmt

Case snDo
EmitDo Stmt

Case snEnd
EmitEnd Stmt

Case snErase
EmitErase Stmt

Case snExit
EmitExit Stmt

Case snFor
EmitFor Stmt

Case snForEach
EmitForEach Stmt

Case snGet
EmitGet Stmt

Case snGoSub
EmitGoSub Stmt

Case snGoTo
EmitGoTo Stmt

Case snIf
EmitIf Stmt

Case snInput
EmitInput Stmt

Case snLabel
EmitLabel Stmt

Case snLet
EmitLet Stmt

Case snLineNumber
EmitLineNumber Stmt

Case snLock
EmitLock Stmt

Case snLSet
EmitLSet Stmt

Case snName
EmitName Stmt

Case snOnError
EmitOnError Stmt

Case snOnComputed
EmitOnComputed Stmt

Case snOpen
EmitOpen Stmt

Case snPrint
EmitPrint Stmt

Case snPut
EmitPut Stmt

Case snRaiseEvent
EmitRaiseEvent Stmt

Case snReDim
EmitReDim Stmt

Case snReset
EmitReset Stmt

Case snResume
EmitResume Stmt

Case snReturn
EmitReturn Stmt

Case snRSet
EmitRSet Stmt

Case snSeek
EmitSeek Stmt

Case snSelect
EmitSelect Stmt

Case snSet
EmitSet Stmt

Case snStop
EmitStop Stmt

Case snUnlock
EmitUnlock Stmt

Case snWhile
EmitWhile Stmt

Case snWidth
EmitWidth Stmt

Case snWith
EmitWith Stmt

Case snWrite
EmitWrite Stmt
End Select
End Sub

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

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

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

If Stmt.Arguments.Count > 0 Then Builder.Append ")"
End Sub

Private Sub EmitClose(ByVal Stmt As CloseConstruct)
Stop
End Sub

Private Sub EmitContinue(ByVal Stmt As ContinueConstruct)
Stop
End Sub

Private Sub EmitDebug(ByVal Stmt As DebugConstruct)
Stop
End Sub

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

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

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

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

Private Sub EmitDo(ByVal Stmt As DoConstruct)
Stop
End Sub

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

Private Sub EmitErase(ByVal Stmt As EraseConstruct)
Stop
End Sub

Private Sub EmitExit(ByVal Stmt As ExitConstruct)
Stop
End Sub

Private Sub EmitFor(ByVal Stmt As ForConstruct)
Stop
End Sub

Private Sub EmitForEach(ByVal Stmt As ForEachConstruct)
Stop
End Sub

Private Sub EmitGet(ByVal Stmt As GetConstruct)
Stop
End Sub

Private Sub EmitGoSub(ByVal Stmt As GoSubConstruct)
Stop
End Sub

Private Sub EmitGoTo(ByVal Stmt As GoToConstruct)
Stop
End Sub

Private Sub EmitIf(ByVal Stmt As IfConstruct)
Dim Arm As IfArm
Dim Idx As Integer

For Idx = 1 To Stmt.Arms.Count
Builder.Append IIf(Idx = 1, "If ", "ElseIf ")
Set Arm = Stmt.Arms(Idx)
EmitExpression Arm.Condition
Builder.AppendLn " Then"

Builder.Indent
EmitBody Arm.Body
Builder.Deindent
Next

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

Builder.Append "End If"
End Sub

Private Sub EmitInput(ByVal Stmt As InputConstruct)
Stop
End Sub

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

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

Private Sub EmitLineNumber(ByVal Stmt As LineNumberConstruct)
Stop
End Sub

Private Sub EmitLock(ByVal Stmt As LockConstruct)
Stop
End Sub

Private Sub EmitLSet(ByVal Stmt As LSetConstruct)
Stop
End Sub

Private Sub EmitName(ByVal Stmt As NameConstruct)
Stop
End Sub

Private Sub EmitOnError(ByVal Stmt As OnErrorConstruct)
Stop
End Sub

Private Sub EmitOnComputed(ByVal Stmt As OnComputedConstruct)
Stop
End Sub

Private Sub EmitOpen(ByVal Stmt As OpenConstruct)
Stop
End Sub

Private Sub EmitPrint(ByVal Stmt As PrintConstruct)
Stop
End Sub

Private Sub EmitPut(ByVal Stmt As PutConstruct)
Stop
End Sub

Private Sub EmitRaiseEvent(ByVal Stmt As RaiseEventConstruct)
Stop
End Sub

Private Sub EmitReDim(ByVal Stmt As ReDimConstruct)
Stop
End Sub

Private Sub EmitReset(ByVal Stmt As ResetConstruct)
Stop
End Sub

Private Sub EmitResume(ByVal Stmt As ResumeConstruct)
Stop
End Sub

Private Sub EmitReturn(ByVal Stmt As ReturnConstruct)
Stop
End Sub

Private Sub EmitRSet(ByVal Stmt As RSetConstruct)
Stop
End Sub

Private Sub EmitSeek(ByVal Stmt As SeekConstruct)
Stop
End Sub

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

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

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

For Each Cond In Cs.Conditions
Count = Count + 1

If Cond.Kind = ekBinaryExpr Then
Set Bin = Cond

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

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

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

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

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

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

Private Sub EmitStop(ByVal Stmt As StopConstruct)
Stop
End Sub

Private Sub EmitUnlock(ByVal Stmt As UnlockConstruct)
Stop
End Sub

Private Sub EmitWhile(ByVal Stmt As WhileConstruct)
Stop
End Sub

Private Sub EmitWidth(ByVal Stmt As WidthConstruct)
Stop
End Sub

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

Builder.Indent
EmitBody Stmt.Body
Builder.Deindent

Builder.AppendLn "End With"
End Sub

Private Sub EmitWrite(ByVal Stmt As WriteConstruct)
Stop
End Sub

Private Sub EmitToken(ByVal Stmt As Token)
Select Case Stmt.Kind
Case tkBinaryNumber
Builder.Append "&B"
Builder.Append Stmt.Text

Case tkDateTime
Builder.Append "#"
Builder.Append Stmt.Text
Builder.Append "#"

Case tkEscapedIdentifier
Builder.Append "["
Builder.Append Stmt.Text
Builder.Append "]"

Case tkFileHandle, tkFloatNumber, tkIntegerNumber, tkSciNumber
Builder.Append Stmt.Text

Case tkHexaNumber
Builder.Append "&H"
Builder.Append Stmt.Text

Case tkIdentifier, tkKeyword
Builder.Append NameBank(Stmt)

Case tkOperator
Builder.Append Replace(NameBank(Stmt), "~", "")

Case tkOctalNumber
Builder.Append "&O"
Builder.Append Stmt.Text

Case tkString
Builder.Append """"
Builder.Append Replace(Stmt.Text, """", """""""")
Builder.Append """"

Case Else
Stop
End Select

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

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

Select Case Stmt.Value.Code
Case opWithBang, opWithDot, opNeg
Rem OK

Case Else
Builder.Append " "
End Select

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

Case Else
Builder.Append " "
EmitToken Stmt.Value
Builder.Append " "
End Select
End If
End Sub
End Class
You can see that not every method has been implemented yet.
Let's see how our Main sub is now:

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

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

Set Parser = New Parser
Parser.Parse Source

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

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

ErrHandler:
MsgBox Err.Description, vbCritical, "Parser Error"
End Sub
Pretty slick in my opinion.
Now let's move our attention to ParseBody.
It turns out, it was not a great idea to make it responsible for dealing with closing tokens such as End Sub or End Function.
I couldn't make it work for other constructs, so I ditched it. Now, ParseBody consumes the End keyword and returns what comes next, so each calling code can check if it is the expected one.

Here is is the updated code:

Private Function ParseBody( _
ByVal Entity As Entity, _
ByVal Body As KeyedList, _
Optional ByVal SingleLine As Boolean, _
Optional ByVal LookAhead As Token _
) As Token
Dim Token As Token
Dim Stmt As IStmt
Dim Xp As Expressionist
Dim Label As LabelConstruct
Dim LinNum As LineNumberConstruct

Set Xp = New Expressionist

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

If Not SingleLine Then
Rem Do we have a line number?
If Token.Kind = tkIntegerNumber Then
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token
Body.Add LinNum
Set Token = NextToken
End If

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

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

Select Case Token.Kind
Case tkKeyword
Select Case Token.Code
Case kwCall
GoSub DiscardLine

Case kwClose
GoSub DiscardLine

Case kwConst
Set Token = ParseConsts(acLocal, Entity, Body, InsideProc:=True)

Case kwContinue
GoSub DiscardLine

Case kwDebug
GoSub DiscardLine

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

Case kwDo
GoSub DiscardLine

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
Set Token = LookAhead
Exit Do
End Select

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

Body.Add New EndConstruct

Case kwErase
GoSub DiscardLine

Case kwExit
GoSub DiscardLine

Case kwFor
GoSub DiscardLine

Case kwGet
GoSub DiscardLine

Case kwGoSub
GoSub DiscardLine

Case kwGoTo
GoSub DiscardLine

Case kwIf
Set Token = ParseIf(Entity, Body)

Case kwInput
GoSub DiscardLine

Case kwLet
GoSub DiscardLine

Case kwLSet
GoSub DiscardLine

Case kwOn
GoSub DiscardLine

Case kwOpen
GoSub DiscardLine

Case kwPrint
GoSub DiscardLine

Case kwPut
GoSub DiscardLine

Case kwRaiseEvent
GoSub DiscardLine

Case kwReDim
GoSub DiscardLine

Case kwResume
GoSub DiscardLine

Case kwReturn
GoSub DiscardLine

Case kwRSet
GoSub DiscardLine

Case kwSeek
GoSub DiscardLine

Case kwSelect
ParseSelect Entity, Body

Case kwSet
GoSub DiscardLine

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

Case kwStop
GoSub DiscardLine

Case kwUnlock
GoSub DiscardLine

Case kwWhile
GoSub DiscardLine

Case kwWith
GoSub DiscardLine

Case kwWrite
GoSub DiscardLine

Case kwWith
ParseWith Entity, Body

Case kwCase, kwElse, kwElseIf, kwLoop, kwNext, kwWend
Exit Do

Case cxName
GoSub DiscardLine

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

Case tkIdentifier
Select Case Token.Code
Case cxLock
GoSub DiscardLine

Case cxReset
GoSub DiscardLine

Case cxWidth
GoSub DiscardLine

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

Case tkDirective
GoSub DiscardLine

Case tkHardLineBreak
Rem Nothing to do

Case Else
Debug.Assert False
Fail Token, Msg087
End Select
Loop Until SingleLine

Set ParseBody = Token
Exit Function

DiscardLine:
Do
Set Token = NextToken
Loop Until IsBreak(Token)

Return
End Function
We've made an entry for each statement we will deal with, but filled many of them temporarily to a call to DiscardLine.

With these changes I could find a lot of bugs that I then fixed retroactively so - hopefully - previous posts will be right at the time of publishing this one.
But not all of them have been presented yet, as some were tiny corrections. I'll leave it to the next dump.
The ones below are kind of a teaser, though.

Private Sub ParseDim( _
ByVal Access As Accessibility, _
ByVal Entity As Entity, _
ByVal Vars As KeyedList, _
Optional ByVal InsideProc As Boolean, _
Optional ByVal IsStatic As Boolean, _
Optional ByVal Token As Token _
)
Dim Name As String
Dim WasArray As Boolean
Dim Tkn As Token
Dim Lit As Literal
Dim Var As Variable
Dim Expr As IExpression
Dim Subs As SubscriptPair
Dim Xp As Expressionist
Dim Uni As UnaryExpression
Dim Bin As BinaryExpression

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

Set Xp = New Expressionist
Xp.CanHaveTo = True

Do
Set Var = New Variable
Var.Access = Access
Var.IsStatic = IsStatic

If Token.IsKeyword(kwWithEvents) Then
If Not Entity.IsClass Then Fail Token, Msg016
If InsideProc Then Fail Token, Msg063

Var.HasWithEvents = True
Set Token = NextToken
End If

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

Set Token = NextToken
WasArray = False

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

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

Case ekBinaryExpr
Set Bin = Expr
Set Subs = New SubscriptPair

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

Case Else
Debug.Assert False
Fail Token, Msg065
End Select

Var.Subscripts.Add Subs
End If

If Token.Kind <> tkListSeparator Then Exit Do
Loop

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

WasArray = True
Set Token = NextToken
End If

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

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

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

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

Set Token = NextToken

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

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

Set Token = NextToken
End If

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

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

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

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

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

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

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

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.Kind = tkIdentifier And Token.Code = cxStep
IsEndOfContext = Result
End Function
Once we are done parsing statements we'll make a copy of Reverter and change this copy to produce code to something else than VB.
That's the goal of our journey.

Next week we'll parse For/Next, For Each/Next, Do/Loop, and While/Wend.

Andrej Biasic
2021-04-07