Let's build a transpiler! Part 35
This is the thirty-fifth post in a series of building a transpiler.You can find the previous ones here.
A new look at As New
Sometimes, wonderful things may be hidden in plain sight.At first, "Dim Xp As New Expressionist" may seem like a shortcut to a longer statement like "Dim Xp As Expressionist: Set Xp = New Expressionist".
But As New does more than that. Whenever a statement having an As New variable is hit when running code, if the variable is Nothing, it will be automagically instantiated.
If no statement mentioning the variable is ever executed, then that variable will remain unset.
Here's an example:
Dim Condition As Boolean
Dim Xp As New Expressionist
Condition = True
If Condition Then
Debug.Print Xp Is Nothing 'This will print False
Else
'Xp is Nothing here.
'We cannot test it as we did above because Xp would be automagically instantiated defeating the test.
End If
Regarding the "chalenge" in my next to last post, the greatest blue words cluster I could come up with is If Not Me Is Nothing Then On Error Resume Next that... does not make any sense, of course.
Back to business
We will parse the remaining statements, that happen to be file I/O ones.Here are the classes:
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 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 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 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 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 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 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 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 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 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 WidthConstruct
Option Explicit
Implements IStmt
Public FileNumber As IExpression
Public Value As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snWidth
End Property
End Class
Public Class WriteConstruct
Option Explicit
Implements IStmt
Private Output_ As KeyedList
Public FileNumber As IExpression
Private Sub Class_Initialize()
Set Output_ = New KeyedList
Set Output_.T = New ExprValidator
End Sub
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snWrite
End Property
Public Property Get Output() As KeyedList
Set Output = Output_
End Property
End Class
And here are Parser's updated methods. GetStmt had several changes, too many to highlight:
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 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
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
If Expr Is Nothing Then
If Token.Kind = tkListSeparator Then
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
ElseIf Token.Kind = tkRightParenthesis Then
Exit Do
End If
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
Private Function ParseBody( _
ByVal Entity As Entity, _
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
Set Xp = New Expressionist
Do
If LookAhead Is Nothing Then
Set Token = SkipLineBreaks
Else
Set Token = LookAhead
Set LookAhead = Nothing
If IsBreak(Token) Then Set Token = SkipLineBreaks
End If
If Not IsSingleLine Then
Rem Do we have a line number?
If Token.Kind = tkIntegerNumber Then
Set LinNum = New LineNumberConstruct
Set LinNum.Value = Token
Body.Add LinNum
Set Token = NextToken
End If
Rem Do we have a label?
If Token.Kind = tkIdentifier Then
Set LookAhead = NextToken
If LookAhead.Kind = tkSoftLineBreak Then
Set Label = New LabelConstruct
Set Label.Id = NewId(Token)
Body.Add Label
Set LookAhead = Nothing
Set Token = NextToken
End If
End If
End If
Select Case Token.Kind
Case tkKeyword
Select Case Token.Code
Case kwCall
Set Stmt = Xp.GetStmt(Me)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail Token, Msg094
If Stmt.Kind <> snCall Then Stop
Body.Add Stmt
Case kwClose
Set LookAhead = ParseClose(Entity, Body)
Case kwConst
Set LookAhead = ParseConsts(acLocal, Entity, Body, InsideProc:=True)
Case kwContinue
ParseContinue Entity, Body
Case kwDebug
Rem HACK:
GoTo Up
Case kwDim
ParseDim acLocal, Entity, Body, InsideProc:=True
Case kwDo
ParseDo Entity, Body
Case kwEnd
Rem Is it a closing End?
Set LookAhead = NextToken
Select Case LookAhead.Kind
Case tkKeyword
Select Case LookAhead.Code
Case kwFunction, kwIf, kwSelect, kwSub, kwWhile, kwWith
Exit Do
End Select
Case tkIdentifier
If LookAhead.Code = cxProperty Then Exit Do
End Select
Body.Add New EndConstruct
Case kwErase
Set LookAhead = ParseErase(Entity, Body)
Case kwExit
ParseExit Entity, Body
Case kwFor
Set LookAhead = ParseFor(Entity, Body)
Case kwGet
ParseGet Entity, Body
Case kwGoSub
ParseGoSub Entity, Body
Case kwGoTo
ParseGoTo Entity, Body
Case kwIf
Set LookAhead = ParseIf(Entity, Body)
Case kwInput
Set LookAhead = ParseInput(Entity, Body)
Case kwLet
Set Stmt = Xp.GetStmt(Me)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail Token, Msg094
If Stmt.Kind <> snLet Then Stop
Body.Add Stmt
Case kwLSet
Set LookAhead = ParseLSet(Entity, Body)
Case kwOn
Set LookAhead = ParseOn(Entity, Body)
Case kwOpen
Set LookAhead = ParseOpen(Entity, Body)
Case kwPrint
Set LookAhead = ParsePrint(Entity, Body)
Case kwPut
ParsePut Entity, Body
Case kwRaiseEvent
Set LookAhead = ParseRaiseEvent(Entity, Body)
Case kwReDim
ParseReDim Entity, Body
Case kwResume
Set LookAhead = ParseResume(Entity, Body)
Case kwReturn
Body.Add New ReturnConstruct
Case kwRSet
Set LookAhead = ParseRSet(Entity, Body)
Case kwSeek
Set LookAhead = ParseSeek(Entity, Body)
Case kwSelect
ParseSelect Entity, Body
Case kwSet
Set Stmt = Xp.GetStmt(Me)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail Token, Msg094
If Stmt.Kind <> snLet Then Stop
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, Entity, Body, InsideProc:=True, IsStatic:=True
Case kwStop
Body.Add New StopConstruct
Case kwUnlock
Set LookAhead = ParseUnlock(Entity, Body)
Case kwWhile
ParseWhile Entity, Body
Case cxWidth
Set LookAhead = ParseWidth(Entity, Body)
Case kwWith
ParseWith Entity, Body
Case kwWrite
Set LookAhead = ParseWrite(Entity, Body)
Case kwCase, kwElse, kwElseIf, kwLoop, kwNext, kwWend
Set LookAhead = Token
Exit Do
Case cxName
Set LookAhead = ParseName(Entity, Body)
Case Else
Rem It should not happen
Debug.Assert False
End Select
Case tkIdentifier
Select Case Token.Code
Case cxLock
Set LookAhead = ParseLock(Entity, Body)
Case cxReset
Body.Add New ResetConstruct
Case cxWidth
Set LookAhead = ParseWidth(Entity, Body)
Case Else
Up:
Set Stmt = Xp.GetStmt(Me, Token, LookAhead)
Set LookAhead = Xp.LastToken
If Stmt Is Nothing Then Fail Token, Msg094
Body.Add Stmt
End Select
Case tkDirective
Do
Set Token = NextToken
Loop Until IsBreak(Token)
Case tkOperator
Select Case Token.Code
Case opWithBang, opWithDot
GoTo Up
Case Else
Debug.Assert False
End Select
Case tkHardLineBreak
Rem Nothing to do
Case Else
Debug.Assert False
Fail Token, Msg087
End Select
Loop Until IsSingleLine
If LookAhead Is Nothing Then
Set ParseBody = NextToken
Else
Set ParseBody = LookAhead
End If
End Function
Private Function ParseClose(ByVal Entity As Entity, ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Expr As IExpression
Dim Xp As Expressionist
Dim Stmt As CloseConstruct
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
End Function
Private Sub ParseGet(ByVal Entity As Entity, ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As GetConstruct
Dim Xp As Expressionist
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, Msg113, Msg114
If Token.Kind <> tkListSeparator Then Fail Token, Msg113, ","
Set Stmt.RecNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken
Rem RecNumber can be nothing
If Token.Kind <> tkListSeparator Then Fail Token, Msg113, ","
Set Token = NextToken
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, Msg113, Msg101
Set Stmt.Var = New Symbol
Set Stmt.Var.Value = Token
Body.Add Stmt
End Sub
Private Function ParseInput(ByVal Entity As Entity, ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Sym As Symbol
Dim Xp As Expressionist
Dim Stmt As InputConstruct
Set Stmt = New InputConstruct
Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken
If Token.Kind <> tkListSeparator Then Fail Token, Msg115, ","
Do
Set Token = NextToken
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, Msg113, Msg101
Set Sym = New Symbol
Set Sym.Value = NewId(Token)
Stmt.Vars.Add Sym
Set Token = NextToken
Loop While Token.Kind = tkListSeparator
Body.Add Stmt
Set ParseInput = Token
End Function
Private Function ParseLock(ByVal Entity As Entity, ByVal Body As KeyedList) As Token
Dim Stmt As LockConstruct
Dim Xp As Expressionist
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, Msg116, Msg114
If Xp.LastToken.Kind = tkListSeparator Then
Xp.CanHaveTo = True
Set Stmt.RecordRange = Xp.GetExpression(Me)
If Stmt.RecordRange Is Nothing Then Fail Xp.LastToken, Msg116, Msg117
End If
Body.Add Stmt
Set ParseLock = Xp.LastToken
End Function
Private Function ParseName(ByVal Entity As Entity, ByVal Body As KeyedList) As Token
Dim Xp As Expressionist
Dim Stmt As NameConstruct
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, Msg118, Msg119
If Xp.LastToken.IsKeyword(kwAs) Then Fail Xp.LastToken, Msg118, vAs
Set Stmt.NewPathName = Xp.GetExpression(Me)
If Stmt.NewPathName Is Nothing Then Fail Xp.LastToken, Msg118, Msg120
Body.Add Stmt
Set ParseName = Xp.LastToken
End Function
Private Function ParseOpen(ByVal Entity As Entity, ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Stmt As OpenConstruct
Dim Xp As Expressionist
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, Msg121, Msg122
If Not Xp.LastToken.IsKeyword(kwFor) Then Fail Xp.LastToken, Msg121, vFor
Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail Token, Msg123
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, Msg123
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, Msg124
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, Msg121, vAs
Set Stmt.FileNumber = Xp.GetExpression(Me)
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, Msg121, Msg114
Set Token = Xp.LastToken
If Token.IsKeyword(cxLen) Then
Set Token = NextToken
If Not Token.IsOperator(opEq) Then Fail Token, Msg121, "="
Set Stmt.Length = Xp.GetExpression(Me)
Set Token = Xp.LastToken
End If
Body.Add Stmt
Set ParseOpen = Token
End Function
Private Function ParsePrint(ByVal Entity As Entity, 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
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, Msg125, Msg114
If Token.Kind <> tkListSeparator Then Fail Token, Msg125, ","
Set Token = Nothing
Do
Set Expr = Xp.GetExpression(Me, Token)
Set Token = Xp.LastToken
If Expr Is Nothing Then Fail Xp.LastToken, Msg125, Msg101
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.Kind = tkIdentifier And Sym.Value.Code = cxSpc Then
If Exec.Arguments.Count > 1 Then Stop
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.Kind = tkIdentifier And Sym.Value.Code = cxTab Then
If Exec.Arguments.Count > 1 Then Stop
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.Kind = tkIdentifier And Sym.Value.Code = 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
End Function
Private Sub ParsePut(ByVal Entity As Entity, ByVal Body As KeyedList)
Dim Token As Token
Dim Stmt As PutConstruct
Dim Xp As Expressionist
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, Msg126, Msg101
If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, Msg126, ","
Set Stmt.RecNumber = Xp.GetExpression(Me)
Set Token = Xp.LastToken
Rem RecNumber can be nothing
If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, Msg126, ","
Set Token = NextToken
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, Msg126, Msg003
Set Stmt.Var = New Symbol
Set Stmt.Var.Value = Token
Body.Add Stmt
End Sub
Private Function ParseSeek(ByVal Entity As Entity, ByVal Body As KeyedList) As Token
Dim Xp As Expressionist
Dim Stmt As SeekConstruct
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, Msg127, Msg101
If Xp.LastToken.Kind <> tkListSeparator Then Fail Xp.LastToken, Msg127, ","
Set Stmt.Position = Xp.GetExpression(Me)
If Stmt.Position Is Nothing Then Fail Xp.LastToken, Msg127, Msg128
Body.Add Stmt
Set ParseSeek = Xp.LastToken
End Function
Private Function ParseUnlock(ByVal Entity As Entity, ByVal Body As KeyedList) As Token
Dim Stmt As UnlockConstruct
Dim Xp As Expressionist
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, Msg129, Msg101
If Xp.LastToken.Kind = tkListSeparator Then
Xp.CanHaveTo = True
Set Stmt.RecordRange = Xp.GetExpression(Me)
If Stmt.RecordRange Is Nothing Then Fail Xp.LastToken, Msg129, Msg117
End If
Body.Add Stmt
Set ParseUnlock = Xp.LastToken
End Function
Private Function ParseWidth(ByVal Entity As Entity, ByVal Body As KeyedList) As Token
Dim Stmt As WidthConstruct
Dim Xp As Expressionist
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, Mg130, Msg101
If Xp.LastToken.Kind <> tkListSeparator Then Fail Xp.LastToken, Msg130, ","
Xp.CanHaveTo = True
Set Stmt.Value = Xp.GetExpression(Me)
If Stmt.Value Is Nothing Then Fail Xp.LastToken, Msg130, Msg131
Body.Add Stmt
Set ParseWidth = Xp.LastToken
End Function
Private Function ParseWrite(ByVal Entity As Entity, ByVal Body As KeyedList) As Token
Dim Token As Token
Dim Expr As IExpression
Dim Xp As Expressionist
Dim Stmt As WriteConstruct
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, Msg132, Msg101
If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, Msg132, ","
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
End Function
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
Xp.FullMode = True
(...)
End Sub
Here are Reverter's new methods:
Private Sub EmitClose(ByVal Stmt As CloseConstruct)
Dim Number As IExpression
Builder.Append "Close"
For Each Number In Stmt.FileNumbers
Builder.Append " "
EmitExpression Number
Next
End Sub
Private Sub EmitGet(ByVal Stmt As GetConstruct)
Builder.Append "Get "
EmitExpression Stmt.FileNumber
Builder.Append ", "
If Not Stmt.RecNumber Is Nothing Then EmitExpression Stmt.RecNumber
Builder.Append ", "
EmitToken Stmt.Var.Value
End Sub
Private Sub EmitInput(ByVal Stmt As InputConstruct)
Dim Count As Integer
Dim Var As Symbol
Builder.Append "Input "
EmitExpression Stmt.FileNumber
Builder.Append ", "
For Each Var In Stmt.Vars
EmitToken Var.Value
Count = Count + 1
If Count <> Stmt.Vars.Count Then Builder.Append ", "
Next
End Sub
Private Sub EmitLock(ByVal Stmt As LockConstruct)
Builder.Append "Lock "
EmitExpression Stmt.FileNumber
Builder.Append ", "
EmitExpression Stmt.RecordRange
End Sub
Private Sub EmitName(ByVal Stmt As NameConstruct)
Builder.Append "Name "
EmitExpression Stmt.OldPathName
Builder.Append " As "
EmitExpression Stmt.NewPathName
End Sub
Private Sub EmitOpen(ByVal Stmt As OpenConstruct)
Builder.Append "Open "
EmitExpression Stmt.PathName
Builder.Append " For "
Select Case Stmt.FileMode
Case fmAppend
Builder.Append "Append"
Case fmBinary
Builder.Append "Binary"
Case fmInput
Builder.Append "Input"
Case fmOutput
Builder.Append "Output"
Case fmRandom
Builder.Append "Random"
End Select
If Stmt.FileAccess <> faNone Then
Builder.Append " Access "
Select Case Stmt.FileAccess
Case faRead
Builder.Append "Read"
Case faReadWrite
Builder.Append "Read Write"
Case faWrite
Builder.Append "Write"
End Select
End If
Select Case Stmt.FileLock
Case flRead
Builder.Append " Read"
Case flReadWrite
Builder.Append " Read Write"
Case flShared
Builder.Append " Shared"
Case flWrite
Builder.Append " Write"
End Select
Builder.Append " As "
EmitExpression Stmt.FileNumber
If Not Stmt.Length Is Nothing Then
Builder.Append " Len="
EmitExpression Stmt.Length
End If
End Sub
Private Sub EmitPrint(ByVal Stmt As PrintConstruct)
Dim Count As Integer
Dim Arg As PrintArg
Builder.Append "Print #"
EmitExpression Stmt.FileNumber
Builder.Append ","
For Each Arg In Stmt.Output
Count = Count + 1
If Not Arg.Indent Is Nothing Then
Builder.Append IIf(Arg.Indent.IsTab, " Tab", " Spc")
If Not Arg.Indent.Value Is Nothing Then
Builder.Append "("
EmitExpression Arg.Indent.Value
Builder.Append ")"
End If
Builder.Append " "
End If
EmitExpression Arg.Value
If Arg.HasSemicolon Then
Builder.Append ";"
Else
If Count <> Stmt.Output.Count Then Builder.Append " "
End If
Next
End Sub
Private Sub EmitPut(ByVal Stmt As PutConstruct)
Builder.Append "Put "
EmitExpression Stmt.FileNumber
Builder.Append ", "
If Not Stmt.RecNumber Is Nothing Then EmitExpression Stmt.RecNumber
Builder.Append ", "
EmitToken Stmt.Var.Value
End Sub
Private Sub EmitReset(ByVal Stmt As ResetConstruct)
Builder.Append "Reset"
End Sub
Private Sub EmitSeek(ByVal Stmt As SeekConstruct)
Builder.Append "Seek "
EmitExpression Stmt.FileNumber
Builder.Append ", "
EmitExpression Stmt.Position
End Sub
Private Sub EmitUnlock(ByVal Stmt As UnlockConstruct)
Builder.Append "Unlock "
EmitExpression Stmt.FileNumber
Builder.Append ", "
EmitExpression Stmt.RecordRange
End Sub
Private Sub EmitWidth(ByVal Stmt As WidthConstruct)
Builder.Append "Width "
EmitExpression Stmt.FileNumber
Builder.Append ", "
EmitExpression Stmt.Value
End Sub
Private Sub EmitWrite(ByVal Stmt As WriteConstruct)
Dim Count As Integer
Dim Expr As IExpression
Builder.Append "Write "
EmitExpression Stmt.FileNumber
Builder.Append ", "
For Each Expr In Stmt.Output
EmitExpression Expr
Count = Count + 1
If Count <> Stmt.Output.Count Then Builder.Append ", "
Next
End Sub
Finally, the error messages:
Public Property Get Msg113() As String
Msg113 = "Rule: Get [#]filenumber, [recnumber], varname"
End Property
Public Property Get Msg114() As String
Msg114 = "#filenumber"
End Property
Public Property Get Msg115() As String
Msg115 = "Rule: Input #filenumber, variable[, variable, ...]"
End Property
Public Property Get Msg116() As String
Msg116 = "Rule: Lock [#]filenumber[, recordrange]"
End Property
Public Property Get Msg117() As String
Msg117 = "recordrange"
End Property
Public Property Get Msg118() As String
Msg118 = "Rule: Name oldpathname As newpathname"
End Property
Public Property Get Msg119() As String
Msg119 = "oldpathname"
End Property
Public Property Get Msg120() As String
Msg120 = "newpathname"
End Property
Public Property Get Msg121() As String
Msg121 = "Rule: Open pathname For mode [Access access] [lock] As [#]filenumber [Len=reclength]"
End Property
Public Property Get Msg122() As String
Msg122 = "pathname"
End Property
Public Property Get Msg123() As String
Msg123 = "Expected: Append or Binary or Input or Random"
End Property
Public Property Get Msg124() As String
Msg124 = "Expected: Read or Write"
End Property
Public Property Get Msg125() As String
Msg125 = "Rule: Print #filenumber, [outputlist]"
End Property
Public Property Get Msg126() As String
Msg126 = "Rule: Put [#]filenumber, [recnumber], varname"
End Property
Public Property Get Msg127() As String
Msg127 = "Rule: Seek [#]filenumber, position"
End Property
Public Property Get Msg128() As String
Msg128 = "position"
End Property
Public Property Get Msg129() As String
Msg129 = "Rule: Unlock [#]filenumber[, recordrange]"
End Property
Public Property Get Msg130() As String
Msg130 = "Rule: Width #filenumber, width"
End Property
Public Property Get Msg131() As String
Msg131 = "width"
End Property
Public Property Get Msg132() As String
Msg132 = "Rule: Write #filenumber, [outputlist]"
End Property
Next week we will convert all this project to VBScript again, but this time dealing with the optional parameters, transforming Vocabulary in a class, solving the bug we workedaround in part 15, and discussing two bugs in VBScript itself!
Andrej Biasic
2021-05-05