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