Regarding ParseFor, it has two interesting things.
The first is that if it detects what it has is a For Each statement, it calls ParseForEach and quits.
The second is that we're dealing with the identifier list after the Next keyword we discussed in a previous post.
It confirms whether its counter variable is in the list or not followed by a comma.
If it is, then it consumes the comma and "cheats" by returning a synthetized Next token.
This way ParseBody will exit earlier and the (presumed) next ParseFor in the call stack will get its Next and deal properly with it.
Now our code can parse itself! Just keep in mind that we did not implement parsing or reversing some statements yet, but this is quite an accomplishment!
Next week, we'll take a look at the past, present, and future of our transpiler.
Andrej Biasic
2021-04-14
Public Class BinaryExpression Option Explicit Implements IExpression
Public LHS As IExpression Public Operator As Operator Public RHS As IExpression
Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekBinaryExpr End Property End Class
Public Class CallConstruct Option Explicit Implements IStmt Implements IExpression
Private Arguments_ As KeyedList
Public LHS As IExpression
Private Sub Class_Initialize() Set Arguments_ = New KeyedList Set Arguments_.T = New ExprValidator End Sub
Public Property Get Arguments() As KeyedList Set Arguments = Arguments_ End Property
Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekIndexer End Property
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snCall End Property End Class
Public Class CaseConstruct Option Explicit
Private Conditions_ As KeyedList Private Body_ As KeyedList
Private Sub Class_Initialize() Set Conditions_ = New KeyedList Set Conditions_.T = New ExprValidator
Set Body_ = New KeyedList Set Body_.T = New StmtValidator End Sub
Public Property Get Conditions() As KeyedList Set Conditions = Conditions_ End Property
Public Property Get Body() As KeyedList Set Body = Body_ End Property End Class
Public Class CloseConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snClose End Property End Class
Public Class ConstConstruct Option Explicit Implements IStmt
Public Access As Accessibility Public Id As Identifier Public DataType As DataType Public Value As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snConst End Property End Class
Public Class ContinueConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snContinue End Property End Class
Public Class DataType Option Explicit
Public Id As Identifier Public IsArray As Boolean Public FixedLength As IExpression End Class
Public Class DebugConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snDebug End Property End Class
Public Class DeclareConstruct Option Explicit
Private Parms_ As KeyedList
Public Access As Accessibility Public IsSub As Boolean Public Id As Identifier Public IsCDecl As Boolean Public LibName As Token Public AliasName As Token Public DataType As DataType
Private Sub Class_Initialize() Set Parms_ = New KeyedList Set Parms_.T = NewValidator(TypeName(New Parameter))
Parms_.CompareMode = vbTextCompare End Sub
Public Property Get Parameters() As KeyedList Set Parameters = Parms_ End Property End Class
Public Class DefaultValidator Option Explicit Option Compare Text Implements IKLValidator
Public AllowedType As String
Private Function IKLValidator_Validate(ByVal Item As Variant) As Boolean
IKLValidator_Validate = TypeName(Item) = AllowedType Debug.Assert IKLValidator_Validate End Function End Class
Public Class DefType Option Explicit Const LAST_INDEX = 25
Private A_Z_ As Boolean Private Letters_(0 To LAST_INDEX) As Token
Public Default Property Get Item(ByVal Letter As String) As DataType Static DfType As Token Dim Index As Integer
If DfType Is Nothing Then Set DfType = New Token
DfType.Kind = tkKeyword
DfType.Code = kwVariant End If
Index = ToIndex(Letter)
If A_Z_ Then Set Item = Letters_(0)
ElseIf Index = -1 Or Letters_(Index) Is Nothing Then Set Item = NewDataType(DfType)
Else Set Item = NewDataType(Letters_(Index)) End If End Property
Public Sub SetRange(ByVal FirstLetter As String, ByVal LastLetter As String, ByVal VariableType As Integer) Dim First As Integer Dim Last As Integer Dim Letter As Integer Dim Token As Token
First = ToIndex(FirstLetter)
Last = ToIndex(LastLetter)
If First > Last Then
Letter = First
First = Last
Last = Letter End If
A_Z_ = First = 0 And Last = LAST_INDEX
Set Token = New Token
Token.Kind = tkKeyword
Select Case VariableType Case vbBoolean
Token.Code = kwBoolean
Case vbByte
Token.Code = kwByte
Case vbInteger
Token.Code = kwInteger
Case vbLong
Token.Code = kwLong
Case vbLongLong
Token.Code = kwLongLong
Case vbLongPtr
Token.Code = kwLongPtr
Case vbCurrency
Token.Code = kwCurrency
Case vbDecimal
Token.Code = cxDecimal
Case vbSingle
Token.Code = kwSingle
Case vbDouble
Token.Code = kwDouble
Case vbDate
Token.Code = kwDate
Case vbString
Token.Code = kwString
Case vbObject
Token.Code = cxObject
Case vbVariant
Token.Code = kwVariant
Case Else Debug.Assert False End Select
For Letter = First To Last If Not Letters_(Letter) Is Nothing Then If Letters_(Letter).Text <> Token.Text Then Err.Raise 0 End If
Set Letters_(Letter) = Token Next End Sub
Private Function ToIndex(ByVal Letter As String) As Integer Const CAPITAL_A = 65 Const CAPITAL_Z = 90 Const SMALL_A = 97
Dim Result As Integer
Debug.Assert Letter <> ""
Result = AscW(Left$(Letter, 1)) If Result >= SMALL_A Then Result = Result - SMALL_A + CAPITAL_A If Result < CAPITAL_A Or Result > CAPITAL_Z Then Result = CAPITAL_A - 1
Result = Result - CAPITAL_A
ToIndex = Result End Function End Class
Public Class DoConstruct Option Explicit Implements IStmt
Public Enum DoWhat
dtNone
dtDoLoop
dtDoWhileLoop
dtDoUntilLoop
dtDoLoopWhile
dtDoLoopUntil End Enum
Private Body_ As KeyedList
Public Condition As IExpression Public DoType As DoWhat
Private Sub Class_Initialize() Set Body_ = New KeyedList Set Body_.T = New StmtValidator End Sub
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snDo End Property
Public Property Get Body() As KeyedList Set Body = Body_ End Property End Class
Public Class EndConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snEnd End Property End Class
Public Class Entity Option Explicit
Private Consts_ As KeyedList Private Enums_ As KeyedList Private Declares_ As KeyedList Private Events_ As KeyedList Private Impls_ As KeyedList Private Vars_ As KeyedList Private Types_ As KeyedList Private Subs_ As KeyedList Private Funcs_ As KeyedList Private Props_ As KeyedList
Public OptionBase As Integer Public OptionCompare As VbCompareMethod Public OptionExplicit As Boolean Public IsClass As Boolean Public Accessibility As Accessibility Public Id As Identifier
Private Sub Class_Initialize() Set Consts_ = New KeyedList Set Consts_.T = NewValidator(TypeName(New ConstConstruct))
Consts_.CompareMode = vbTextCompare
Set Enums_ = New KeyedList Set Enums_.T = NewValidator(TypeName(New EnumConstruct))
Enums_.CompareMode = vbTextCompare
Set Declares_ = New KeyedList Set Declares_.T = NewValidator(TypeName(New DeclareConstruct))
Declares_.CompareMode = vbTextCompare
Set Events_ = New KeyedList Set Events_.T = NewValidator(TypeName(New EventConstruct))
Events_.CompareMode = vbTextCompare
Set Impls_ = New KeyedList Set Impls_.T = NewValidator(TypeName(New ImplementsConstruct))
Impls_.CompareMode = vbTextCompare
Set Vars_ = New KeyedList Set Vars_.T = NewValidator(TypeName(New Variable))
Vars_.CompareMode = vbTextCompare
Set Types_ = New KeyedList Set Types_.T = NewValidator(TypeName(New TypeConstruct))
Types_.CompareMode = vbTextCompare
Set Subs_ = New KeyedList Set Subs_.T = NewValidator(TypeName(New SubConstruct))
Subs_.CompareMode = vbTextCompare
Set Funcs_ = New KeyedList Set Funcs_.T = NewValidator(TypeName(New FunctionConstruct))
Funcs_.CompareMode = vbTextCompare
Set Props_ = New KeyedList Set Props_.T = NewValidator(TypeName(New PropertySlot))
Props_.CompareMode = vbTextCompare End Sub
Public Static Property Get DefTypes() As DefType Dim Hidden As New DefType Set DefTypes = Hidden End Property
Public Property Get Consts() As KeyedList Set Consts = Consts_ End Property
Public Property Get Enums() As KeyedList Set Enums = Enums_ End Property
Public Property Get Declares() As KeyedList Set Declares = Declares_ End Property
Public Property Get Events() As KeyedList Set Events = Events_ End Property
Public Property Get Impls() As KeyedList Set Impls = Impls_ End Property
Public Property Get Vars() As KeyedList Set Vars = Vars_ End Property
Public Property Get Types() As KeyedList Set Types = Types_ End Property
Public Property Get Subs() As KeyedList Set Subs = Subs_ End Property
Public Property Get Functions() As KeyedList Set Functions = Funcs_ End Property
Public Property Get Properties() As KeyedList Set Properties = Props_ End Property End Class
Public Class EnumConstruct Option Explicit
Private Enumerands_ As KeyedList
Public Access As Accessibility Public Id As Identifier
Private Sub Class_Initialize() Set Enumerands_ = New KeyedList Set Enumerands_.T = NewValidator(TypeName(New EnumerandConstruct))
Enumerands_.CompareMode = vbTextCompare End Sub
Public Property Get Enumerands() As KeyedList Set Enumerands = Enumerands_ End Property End Class
Public Class EnumerandConstruct Option Explicit
Public Access As Accessibility Public Id As Identifier Public Value As IExpression End Class
Public Class EraseConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snErase End Property End Class
Public Class EventConstruct Option Explicit
Private Parms_ As KeyedList
Public Id As Identifier
Private Sub Class_Initialize() Set Parms_ = New KeyedList Set Parms_.T = NewValidator(TypeName(New Parameter))
Parms_.CompareMode = vbTextCompare End Sub
Public Property Get Access() As Accessibility
Access = acPublic End Property
Public Property Get Parameters() As KeyedList Set Parameters = Parms_ End Property End Class
Public Class ExitConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snExit End Property End Class
Public Class Expressionist Option Explicit
Private LastToken_ As Token
Public CanHaveTo As Boolean Public FullMode As Boolean
Public Property Get LastToken() As Token Set LastToken = LastToken_ End Property
Private Function Peek(ByVal Stack As KeyedList) As Variant Set Peek = Stack(Stack.Count) End Function
Private Function Pop(ByVal Stack As KeyedList) As Variant Dim Index As Long
Index = Stack.Count Set Pop = Stack(Index)
Stack.Remove Index End Function
Rem Adapted from https://stackoverflow.com/questions/16380234/handling-extra-operators-in-shunting-yard/16392115#16392115 Public Function GetExpression(ByVal Parser As Parser, Optional ByVal Token As Token) As IExpression Dim HadTo As Boolean Dim WantOperand As Boolean Dim Cp As Integer Dim Sym As Symbol Dim Lit As Literal Dim Op As Operator Dim Op2 As Operator Dim OpStack As KeyedList Dim OutStack As KeyedList Dim Handle As FileHandle Dim Args As TupleConstruct
Set OpStack = New KeyedList Set OpStack.T = NewValidator(TypeName(New Operator))
Set OutStack = New KeyedList Set OutStack.T = New ExprValidator
WantOperand = True
Do If Token Is Nothing Then Set Token = Parser.NextToken
If WantOperand Then
WantOperand = False
Select Case Token.Kind Case tkOperator
WantOperand = True
Select Case Token.Code Case opSum
Token.Code = opId
Case opSubt
Token.Code = opNeg
Rem Unary operators Case opAddressOf, opNew, opNot, opTypeOf, opWithBang, opWithDot Rem OK
Case Else Exit Do End Select
Set Op = NewOperator(Token)
OpStack.Add Op
Case tkLeftParenthesis Rem Pseudo-operator Set Op = NewOperator(Token)
OpStack.Add Op
WantOperand = True
Case tkIdentifier, tkEscapedIdentifier Set Sym = New Symbol Set Sym.Value = Token
OutStack.Add Sym
Case tkIntegerNumber, tkFloatNumber, tkSciNumber, tkBinaryNumber, _
tkOctalNumber, tkHexaNumber, tkString, tkDateTime Set Lit = New Literal Set Lit.Value = Token
OutStack.Add Lit
Case tkFileHandle Set Handle = New FileHandle Set Handle.Value = Token
OutStack.Add Handle
Case tkKeyword Select Case Token.Code Case kwTrue, kwFalse, kwNothing, kwEmpty, kwNull, kwMe Set Lit = New Literal Set Lit.Value = Token
OutStack.Add Lit
Case kwInput, kwSeek Set Sym = New Symbol Set Sym.Value = Token
OutStack.Add Sym
Case kwByVal
Token.Kind = tkOperator
Token.Code = opByVal GoTo Down
Case Else Exit Do End Select
Case Else Exit Do End Select Else If Parser.IsBreak(Token) Then While OpStack.Count > 0
Move OpStack, OutStack Wend
Exit Do End If
Select Case Token.Kind Case tkOperator
Down: Rem Unary and compound operators Select Case Token.Code Case opAddressOf, opNew, opNot, opTypeOf
Parser.Fail Token, Msg065
Case opCompAnd, opCompEqv, opCompImp, _
opCompMod, opCompOr, opCompXor, opCompSum, opCompSubt, opCompMul, opCompDiv, _
opCompIntDiv, opCompPow, opCompLSh, opCompRSh, opCompURSh, opCompConcat Exit Do End Select
Set Op2 = NewOperator(Token)
Do While OpStack.Count > 0 Set Op = Peek(OpStack) If Op.Value.Kind = tkLeftParenthesis Then Exit Do
Cp = ComparePrecedence(Op, Op2) If Cp = -1 Then Exit Do
Move OpStack, OutStack, Op Loop
OpStack.Add Op2
WantOperand = True
Case tkRightParenthesis Do While OpStack.Count > 0 Set Op = Peek(OpStack) If Op.Value.Kind = tkLeftParenthesis Then Exit Do
Move OpStack, OutStack, Op Loop
Rem It is allowed to not have a "(" on OpStack because we can be evaluating the following: Rem Sub A(Optional B As Integer = 1) Rem We'll get to ")" without having ")" on stack. If OpStack.Count = 0 Then Exit Do
Pop OpStack
Case tkKeyword If Token.Code <> kwTo Then Exit Do If Not CanHaveTo Or HadTo Then Err.Raise vbObjectError + 13
HadTo = True
Set Args = New TupleConstruct Set Token = CollectArgs(Args.Elements, Parser) If Token.Kind <> tkRightParenthesis Then Debug.Assert False 'TODO: Error
OutStack.Add Args
Case Else Exit Do End Select End If
Set Token = Nothing Loop
Set LastToken_ = Token
Do While OutStack.Count > 1 Or OutStack.Count = 1 And OpStack.Count > 0 Set Op = Peek(OpStack) If Op.Value.Kind = tkLeftParenthesis Then Exit Do
Move OpStack, OutStack, Op Loop
Debug.Assert OpStack.Count = 0 Debug.Assert OutStack.Count <= 1 If OutStack.Count = 1 Then Set GetExpression = Pop(OutStack) End Function
Private Sub Move(ByVal OpStack As KeyedList, ByVal OutStack As KeyedList, Optional ByVal Op As Operator) Dim Elem As Variant Dim IExpr As IExpression Dim Exec As CallConstruct Dim Tup As TupleConstruct Dim Uni As UnaryExpression Dim Bin As BinaryExpression
If Op Is Nothing Then Set Op = Peek(OpStack)
If Op.IsUnary Then Set Uni = New UnaryExpression Set Uni.Operator = Op Set Uni.Value = Pop(OutStack) Set IExpr = Uni
ElseIf Op.Value.Code = opApply Then Set Exec = New CallConstruct Set Tup = Pop(OutStack)
For Each Elem In Tup.Elements
Exec.Arguments.Add Elem Next
Set Exec.LHS = Pop(OutStack) Set IExpr = Exec
Else Set Bin = New BinaryExpression Set Bin.Operator = Op Set Bin.RHS = Pop(OutStack) Set Bin.LHS = Pop(OutStack) Set IExpr = Bin End If
OutStack.Add IExpr
Pop OpStack End Sub
Public Function GetStmt(ByVal Parser As Parser, 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 Bin As BinaryExpression
Set Xp = New Expressionist
Set Sym = New Symbol Set Sym.Value = Token Set Name = Sym
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
Set Asg = New LetConstruct Set Asg.Operator = NewOperator(Token) Set Asg.Name = Name
Xp.FullMode = True
Asg.Value = Xp.GetExpression(Parser) 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
Rem Method call with no arguments. Set Exec = New CallConstruct Set Exec.LHS = Name 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
Private 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 And 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 End If
Args.Add Expr
If Token.Kind = tkRightParenthesis Then Exit Do If Token.Kind <> tkListSeparator Then Exit Do Set Token = Nothing Loop
Set CollectArgs = Token End Function End Class
Public Class ExprValidator Option Explicit Implements IKLValidator
Private Function IKLValidator_Validate(ByVal Item As Variant) As Boolean
IKLValidator_Validate = TypeOf Item Is IExpression End Function End Class
Public Class FileHandle Option Explicit Implements IExpression
Public Value As Token
Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekFileHandle End Property End Class
Public Class FileTextBuilder Option Explicit
Implements ITextBuilder
Private IsNewLine_ As Boolean Private Indent_ As Integer Private Handle_ As Integer
Public Property Let FilePath(ByVal Value As String)
Handle_ = FreeFile Open Value For Output Access Write As Handle_ End Property
Private Sub Class_Terminate() Close Handle_ End Sub
Private Sub ITextBuilder_Append(ByVal Text As String) If IsNewLine_ Then Print #Handle_, vbNewLine; If Indent_ > 0 Then Print #Handle_, String$(Indent_, vbTab); End If
IsNewLine_ = False Print #Handle_, Text; End Sub
Private Sub ITextBuilder_AppendLn(Optional ByVal Text As String) If Text = ""Then If IsNewLine_ Then Print #Handle_, vbNewLine; Else
ITextBuilder_Append Text End If
IsNewLine_ = True End Sub
Private Sub ITextBuilder_Deindent()
Indent_ = Indent_ - 1 End Sub
Private Sub ITextBuilder_Indent()
Indent_ = Indent_ + 1 End Sub End Class
Public Class ForConstruct Option Explicit Implements IStmt
Private Body_ As KeyedList
Public Counter As Symbol Public StartValue As IExpression Public EndValue As IExpression Public Increment As IExpression
Private Sub Class_Initialize() Set Body_ = New KeyedList Set Body_.T = New StmtValidator End Sub
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snFor End Property
Public Property Get Body() As KeyedList Set Body = Body_ End Property End Class
Public Class ForEachConstruct Option Explicit Implements IStmt
Private Body_ As KeyedList
Public Element As Symbol Public Group As IExpression
Private Sub Class_Initialize() Set Body_ = New KeyedList Set Body_.T = New StmtValidator End Sub
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snForEach End Property
Public Property Get Body() As KeyedList Set Body = Body_ End Property End Class
Public Class FunctionConstruct Option Explicit
Private Parms_ As KeyedList Private Body_ As KeyedList
Public Access As Accessibility Public IsStatic As Boolean Public IsDefault As Boolean Public IsIterator As Boolean Public Id As Identifier Public DataType As DataType
Private Sub Class_Initialize() Set Parms_ = New KeyedList Set Parms_.T = NewValidator(TypeName(New Parameter))
Parms_.CompareMode = vbTextCompare
Set Body_ = New KeyedList Set Body_.T = New StmtValidator End Sub
Public Property Get Parameters() As KeyedList Set Parameters = Parms_ End Property
Public Static Property Get Body() As KeyedList Set Body = Body_ End Property End Class
Public Class GetConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snGet End Property End Class
Public Class GoSubConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snGoSub End Property End Class
Public Class GoToConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snGoTo End Property End Class
Public Class Identifier Option Explicit
Private Name_ As Token Private Project_ As Token
Public Property Get Name() As Token Set Name = Name_ End Property
Public Property Set Name(ByVal Value As Token) If Not Name_ Is Nothing Then Set Project_ = Name_ Set Name_ = Value End Property
Public Property Get Project() As Token Set Project = Project_ End Property End Class
Public Class IExpression Option Explicit
Public Enum ExpressionKind
ekLiteral
ekSymbol
ekFileHandle
ekTuple
ekUnaryExpr
ekBinaryExpr
ekIndexer End Enum
Private Sub Class_Initialize()
Err.Raise 5 End Sub
Public Property Get Kind() As ExpressionKind End Property End Class
Public Class IfArm Option Explicit
Private Body_ As KeyedList
Public Condition As IExpression
Private Sub Class_Initialize() Set Body_ = New KeyedList Set Body_.T = New StmtValidator End Sub
Public Property Get Body() As KeyedList Set Body = Body_ End Property End Class
Public Class IfConstruct Option Explicit Implements IStmt
Private Arms_ As KeyedList Private ElseBody_ As KeyedList
Private Sub Class_Initialize() Set Arms_ = New KeyedList Set Arms_.T = NewValidator(TypeName(New IfArm))
Set ElseBody_ = New KeyedList Set ElseBody_.T = New StmtValidator End Sub
Public Property Get Arms() As KeyedList Set Arms = Arms_ End Property
Public Property Get ElseBody() As KeyedList Set ElseBody = ElseBody_ End Property
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snIf End Property End Class
Public Class IKLValidator Option Explicit
Private Sub Class_Initialize()
Err.Raise 5 End Sub
Public Function Validate(ByVal Item As Variant) As Boolean End Function End Class
Public Class ImplementsConstruct Option Explicit
Public Static Property Get Id() As Identifier Dim Hidden As New Identifier
Set Id = Hidden End Property End Class
Public Class InputConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snInput End Property End Class
Private Sub Class_Initialize()
Err.Raise 5 End Sub
Public Property Get Kind() As StmtNumbers End Property End Class
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
Public Class KeyedList Option Explicit Private ReadOnly_ As Boolean Private Base_ As Integer Private ID_ As Long Private Count_ As Long Private Root_ As KLNode Private Last_ As KLNode Private Validator_ As IKLValidator Private CompareMode_ As VbCompareMethod
Private Sub Class_Initialize()
ID_ = &H80000000
Base = 1 End Sub
Private Sub Class_Terminate()
ReadOnly_ = False
Clear End Sub
Public Sub AddKeyValue(ByVal Key As String, ByVal Item As Variant)
Add Item, Key End Sub
Public Sub Add(ByVal Item As Variant, Optional ByVal Key As Variant) Const Id = "72E0DEDF0CD34921A650C8DD99F21A68_"
Dim NewKey As String Dim NewNode As KLNode
If ReadOnly_ Then Err.Raise 5 If Not Validator_ Is Nothing Then: If Not Validator_.Validate(Item) Then Err.Raise 13
Select Case VarType(Key) Case vbString
NewKey = CStr(Key)
Case vbError If Not IsMissing(Key) Then Err.Raise 13
NewKey = Id & Hex$(ID_)
ID_ = ID_ + 1
Case Else
Err.Raise 13 End Select
If Root_ Is Nothing Then Set Root_ = New KLNode
Root_.Key = NewKey If IsObject(Item) Then Set Root_.Value = Item Else Root_.Value = Item Set Last_ = Root_
Else If Not FindNode(NewKey) Is Nothing Then Err.Raise 457
Set NewNode = New KLNode
NewNode.Key = NewKey If IsObject(Item) Then Set NewNode.Value = Item Else NewNode.Value = Item
Set Last_.NextNode = NewNode Set Last_ = NewNode End If
Count_ = Count_ + 1 End Sub
Public Property Get Count() As Long
Count = Count_ End Property
Public Default Property Get Item(ByVal Index As Variant) As Variant Dim Node As KLNode
Set Node = FindNode(Index) If Node Is Nothing Then Err.Raise 5 If IsObject(Node.Value) Then Set Item = Node.Value Else Item = Node.Value End Property
Public Property Get Exists(ByVal Key As String) As Boolean
Exists = Not FindNode(Key) Is Nothing End Property
Public Property Get Base() As Integer
Base = Base_ End Property
Public Property Let Base(ByVal Value As Integer) If ReadOnly_ Then Err.Raise 5
Base_ = Value End Property
Public Property Get CompareMode() As VbCompareMethod
CompareMode = CompareMode_ End Property
Public Property Let CompareMode(ByVal Value As VbCompareMethod) If ReadOnly_ Then Err.Raise 5
CompareMode_ = Value End Property
Public Sub Remove(ByVal Index As Variant) Dim Found As Boolean Dim Idx As Long Dim Key As String Dim CurNode As KLNode Dim PrvNode As KLNode
If ReadOnly_ Then Err.Raise 5 Set CurNode = Root_
If VarType(Index) = vbString Then
Key = CStr(Index)
Do Until CurNode Is Nothing If StrComp(CurNode.Key, Key, CompareMode) = 0 Then If Not PrvNode Is Nothing Then Set PrvNode.NextNode = CurNode.NextNode
Found = True Exit Do End If
Set PrvNode = CurNode Set CurNode = CurNode.NextNode Loop Else
Idx = CLng(Index)
Idx = Idx - Base
Do Until CurNode Is Nothing If Idx = 0 Then If CurNode Is Root_ Then Set Root_ = CurNode.NextNode
ElseIf Not PrvNode Is Nothing Then Set PrvNode.NextNode = CurNode.NextNode End If
If CurNode Is Last_ Then Set Last_ = PrvNode
Found = True Exit Do End If
Idx = Idx - 1 Set PrvNode = CurNode Set CurNode = CurNode.NextNode Loop End If
If Found Then Count_ = Count_ - 1 Else Err.Raise 5 End Sub
Public Iterator Function NewEnum() As IUnknown Dim It As KLEnumerator
Set It = New KLEnumerator Set It.List = Me Set NewEnum = It.NewEnum End Function
Public Sub Clear() Dim CurrNode As KLNode Dim NextNode As KLNode
If ReadOnly_ Then Err.Raise 5 Set CurrNode = Root_ Set Root_ = Nothing
Do Until CurrNode Is Nothing Set NextNode = CurrNode.NextNode Set CurrNode.NextNode = Nothing Set CurrNode = NextNode Loop
Count_ = 0 End Sub
Private Function FindNode(ByVal Index As Variant) As KLNode Dim Idx As Long Dim Node As KLNode
If VarType(Index) = vbString Then Set Node = FindKey(CStr(Index)) Else
Idx = CLng(Index)
Idx = Idx - Base
If Idx >= 0 Then Set Node = Root_ Do Until Node Is Nothing Or Idx = 0 Set Node = Node.NextNode
Idx = Idx - 1 Loop End If End If
Set FindNode = Node End Function
Private Function FindKey(ByVal Key As String) As KLNode Dim Node As KLNode
Set Node = Root_
Do Until Node Is Nothing If StrComp(Node.Key, Key, CompareMode) = 0 Then Set FindKey = Node Exit Function End If
Set Node = Node.NextNode Loop End Function
Public Property Get IndexOf(ByVal Key As String) As Long Dim Count As Long Dim Node As KLNode
Set Node = Root_
Do Until Node Is Nothing If StrComp(Node.Key, Key, CompareMode) = 0 Then
IndexOf = Count + Base Exit Property End If
Set Node = Node.NextNode
Count = Count + 1 Loop End Property
Public Sub AddValues(ParamArray Values() As Variant) Dim Value As Variant
For Each Value In Values
Add Value Next End Sub
Public Sub AddKVPairs(ParamArray KeyValuePairs() As Variant) Dim Idx As Long Dim Udx As Long
Udx = UBound(KeyValuePairs) If Udx Mod 2 = 0 Then Err.Raise 5
For Idx = 0 To Udx Step 2
Add KeyValuePairs(Idx + 1), KeyValuePairs(Idx) Next End Sub
Public Property Get ReadOnly() As Boolean
ReadOnly = ReadOnly_ End Property
Public Property Let ReadOnly(ByVal Value As Boolean) If ReadOnly_ Then Err.Raise 5
ReadOnly_ = Value End Property
Public Property Set T(ByVal Value As IKLValidator) Set Validator_ = Value End Property End Class
Private Class KLEnumerator Option Explicit
Private Index_ As Long Private List_ As KeyedList Private WithEvents VbEnum As VariantEnumerator
Public Property Set List(ByVal Value As KeyedList) Set List_ = Value
Index_ = List_.Base Set VbEnum = New VariantEnumerator End Property
Public Function NewEnum() As IUnknown Set NewEnum = VbEnum.NewEnum(Me) End Function
Private Sub VbEnum_Clone(ByRef Obj As Variant, ByRef Data As Variant) Debug.Assert False End Sub
Private Sub VbEnum_NextItem(ByVal Qty As Long, ByRef Items As Variant, ByRef Returned As Long, ByRef Data As Variant) If Index_ > List_.Count Then Exit Sub
If IsObject(List_(Index_)) Then Set Items = List_(Index_) Else Items = List_(Index_)
Index_ = Index_ + 1
Returned = 1 End Sub
Private Sub VbEnum_Reset(ByRef Data As Variant)
Index_ = List_.Base End Sub
Private Sub VbEnum_Skip(ByVal Qty As Long, ByRef Data As Variant)
Index_ = Index_ + Qty End Sub End Class
Private Class KLNode Option Explicit
Public NextNode As KLNode Public Key As String Public Value As Variant End Class
Public Class LabelConstruct Option Explicit Implements IStmt
Public Id As Identifier
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLabel End Property End Class
Public Class LetConstruct Option Explicit Implements IStmt
Public Name As IExpression Public Operator As Operator Public Value As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLet End Property End Class
Public Class LineNumberConstruct Option Explicit Implements IStmt
Public Value As Token
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLineNumber End Property End Class
Public Class Literal Option Explicit Implements IExpression
Public Value As Token
Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekLiteral End Property End Class
Public Class LockConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLock End Property End Class
Public Class LSetConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLSet End Property End Class
Public Class NameBank Option Explicit
Private Ids_ As KeyedList Private Keywords_ As KeyedList Private Operators_ As KeyedList Private Contextuals_ As KeyedList
Private 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
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
Public Class NameConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snName End Property End Class
Public Class OnComputedConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snOnComputed End Property End Class
Public Class OnErrorConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snOnError End Property End Class
Public Class OpenConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snOpen End Property End Class
Public Class Operator Option Explicit
Public Value As Token
Public Property Get IsUnary() As Boolean Select Case Value.Code Case opAddressOf, opNew, opNot, opTypeOf, opId, opNeg, opWithDot, opWithBang, opByVal
IsUnary = True End Select End Property
Public Property Get IsBinary() As Boolean
IsBinary = Not IsUnary End Property End Class
Public Class Parameter Option Explicit
Public Index As Integer Public IsOptional As Boolean Public IsByVal As Boolean Public IsParamArray As Boolean Public IsArray As Boolean Public DataType As DataType Public Id As Identifier Public Init As IExpression End Class
Public Class Parser Option Explicit Option Compare Binary
Public Enum Accessibility
acLocal
acPublic
acPrivate
acFriend End Enum
Public Enum SignatureKind
skSub = 1
skFunction
skPropertyGet
skPropertyLet
skPropertySet
skDeclare
skEvent
skTuple End Enum
Private Type AccessToken
Access As Accessibility
Token As Token End Type
Private Downgrade_ As Boolean Private WasAs_ As Boolean Private LastToken_ As Token Private LookAhead_ As Token Private Scanner_ As Scanner Private Source_ As SourceFile Private State_ As NarrowContext
Private Sub Class_Initialize() Set Scanner_ = New Scanner End Sub
Public Property Set SourceFile(ByVal Source As SourceFile) Set Scanner_ = New Scanner Set Source_ = Source
Scanner_.OpenFile Source_.Path
Downgrade_ = False
WasAs_ = False Set LastToken_ = New Token
State_ = ncNone Set LookAhead_ = Nothing End Property
Public Property Get SourceFile() As SourceFile Set SourceFile = Source_ End Property
Public Property Get Scanner() Set Scanner = Scanner_ End Property
' Marks [Access], [Alias], [Append], [Base], [Binary], [Compare], [Error], [Explicit], [Lib], [Line], [Name], [Output], ' [PtrSafe], [Random], [Read], [Reset], [Step], [Text], and [Width] as keywords according to their context. ' ' Turns unary [.] and [!] into [~.] and [~!] respectively. ' ' Changes keywords after [.] or [!] into regular identifiers. ' ' Downgrades [String] and [Date] to regular identifiers when used as functions. Public Function NextToken(Optional ByVal ForPrint As Boolean) As Token Dim Done As Boolean Dim Revoke As Boolean Dim Upgrade As Boolean Dim Spaces As Long Dim Name As String Dim Token As Token Dim LastToken As Token
Do
Done = True
If LookAhead_ Is Nothing Then Set Token = Scanner_.GetToken Else Set Token = LookAhead_ Set LookAhead_ = Nothing End If
If IsEndOfContext(Token) Then
State_ = ncNone Else Select Case Token.Kind Case tkOperator
WasAs_ = False
Downgrade_ = Token.Code = opDot Or Token.Code = opBang
If Spaces <> 0 Then If Token.Code = opDot Then
Token.Code = opWithDot ElseIf Token.Code = opBang Then
Token.Code = opWithBang End If End If
Case tkKeyword If Downgrade_ Then
Downgrade_ = False
Name = NameBank(Token)
If NameBank.Ids.Exists(Name) Then
NameBank.Ids.Add Name, Name
Token.Code = NameBank.Ids.Count End If
Token.Kind = tkIdentifier
Else Select Case Token.Code Case kwAs
WasAs_ = True
Select Case State_ Case ncOpen03, ncOpen05, ncOpen06, ncOpen08, ncOpen09
State_ = ncOpen10 End Select
Case kwDate, kwString If Not WasAs_ Then Token.Kind = tkIdentifier
Case kwDeclare If State_ = ncNone Then State_ = ncDeclare
Case kwFor If State_ = ncNone Then
State_ = ncForNext
ElseIf State_ = ncOpen01 Then
State_ = ncOpen02 End If
Case kwInput If State_ = ncOpen02 Then State_ = ncOpen03
Case cxLock Select Case State_ Case ncOpen05, ncOpen06
State_ = ncOpen07 End Select
Case kwOpen If State_ = ncNone Then State_ = ncOpen01
Case kwOption If State_ = ncNone Then State_ = ncOption
Case kwOn If State_ = ncNone Then State_ = ncOn
Case cxShared Select Case State_ Case ncOpen03, ncOpen04, ncOpen06
State_ = ncOpen09 End Select
Case kwTo If State_ = ncForNext Then State_ = ncForTo
Case kwWrite Select Case State_ Case ncOpen04, ncOpen05
State_ = ncOpen06
Case ncOpen07, ncOpen08
State_ = ncOpen09 End Select End Select End If
Case tkIdentifier
Downgrade_ = False
WasAs_ = False
Select Case State_ Case ncNone Select Case Token.Code Case cxLine Set LookAhead_ = Scanner_.GetToken
Upgrade = LookAhead_.Kind = tkKeyword And LookAhead_.Code = kwInput
Case cxName, cxReset
Upgrade = LastToken_.Kind <> tkKeyword Or LastToken_.Code <> kwCall
If Upgrade Then Set LastToken = LastToken_ Set LastToken = Token Set LookAhead_ = NextToken() Set LastToken_ = LastToken
If Upgrade Then
Upgrade = LookAhead_.Kind <> tkKeyword Or LookAhead_.Code <> kwAs End If
If Upgrade Then Upgrade = LookAhead_.Kind <> tkOperator If Upgrade Then Upgrade = LookAhead_.Kind <> tkLeftParenthesis If Upgrade Then Upgrade = Not IsEndOfContext(LookAhead_) End If
Case cxWidth Set LookAhead_ = Scanner_.GetToken
Upgrade = LookAhead_.Kind = tkFileHandle End Select
Case ncOption
Upgrade = Token.Code = cxBase If Not Upgrade Then Upgrade = Token.Code = cxExplicit
If Not Upgrade Then
Upgrade = Token.Code = cxCompare If Upgrade Then State_ = ncOptionCompare End If
Case ncOptionCompare
Upgrade = Token.Code = cxBinary If Not Upgrade Then Upgrade = Token.Code = cxText
Case ncDeclare
Upgrade = Token.Code = kwPtrSafe
If Upgrade Then
State_ = ncDeclareLib Else
Upgrade = Token.Code = cxLib If Upgrade Then State_ = ncDeclareAlias End If
Case ncDeclareLib
Upgrade = Token.Code = cxLib If Upgrade Then State_ = ncDeclareAlias
Case ncDeclareAlias
Upgrade = Token.Code = cxAlias
Revoke = True
Case ncForTo
Upgrade = Token.Code = cxStep
Revoke = True
Case ncOn
Upgrade = Token.Code = cxError
Revoke = True
Case ncOpen02
Upgrade = Token.Code = cxAppend If Not Upgrade Then Upgrade = Token.Code = cxBinary If Not Upgrade Then Upgrade = Token.Code = cxOutput If Not Upgrade Then Upgrade = Token.Code = cxRandom
State_ = ncOpen03
Case ncOpen03
Upgrade = Token.Code = cxAccess If Upgrade Then State_ = ncOpen04
Case ncOpen05, ncOpen06
Upgrade = Token.Code = cxShared If Upgrade Then State_ = ncOpen09
Case ncOpen04
Upgrade = Token.Code = cxRead If Upgrade Then State_ = ncOpen05
Case ncOpen07
Upgrade = Token.Code = cxRead If Upgrade Then State_ = ncOpen08
Case ncOpen11
Upgrade = Token.Code = cxLen
Revoke = True End Select
Case tkFileHandle If State_ = ncOpen10 Then State_ = ncOpen11
Case tkLineContinuation If Not ForPrint Then Set Token = NextToken()
While IsBreak(Token) Set Token = NextToken() Wend End If
Case tkWhiteSpace
Done = False
Spaces = Spaces + 1
Case tkSoftLineBreak, tkHardLineBreak
WasAs_ = False End Select
If Upgrade Then If Token.Suffix <> vbNullChar Then Fail Token, Msg060
Token.Kind = tkKeyword
Name = NameBank(Token)
Token.Code = NameBank.Contextuals.IndexOf(Name) + NameBank.Keywords.Count If Revoke Then State_ = ncNone End If End If
If Token.Kind <> tkWhiteSpace Then Set LastToken_ = Token Loop Until Done
If Token.Kind <> tkHardLineBreak And Token.Spaces = 0 Then Token.Spaces = Spaces Set NextToken = Token End Function
Rem Parses Source's content. Rem Results are in Source's properties like Consts, Enums, etc. Public Sub Parse(ByVal Source As SourceFile) Dim Name As String Dim Token As Token Dim Mark As Token Dim Entity As Entity Dim AccessToken As AccessToken
Set SourceFile = Source
Do Set Entity = New Entity
Set Token = SkipLineBreaks If Token.Kind = tkEndOfStream Then Exit Do
If Token.IsKeyword(kwPublic) Then
Entity.Accessibility = acPublic Set Token = NextToken
ElseIf Token.IsKeyword(kwPrivate) Then
Entity.Accessibility = acPrivate Set Token = NextToken End If
If Token.IsKeyword(kwClass) Then
Entity.IsClass = True
ElseIf Token.IsKeyword(kwModule) Then Rem Nothing to do.
ElseIf Entity.Accessibility = acLocal Then
Fail Token, Msg007, Msg001
Else
Fail Token, Msg007, Msg002 End If
Set Mark = Token
If Entity.Accessibility = acLocal Then Entity.Accessibility = acPublic Set Token = NextToken If Not IsProperId(Token) Then Fail Token, Msg007, Msg003
Set Entity.Id = NewId(Token)
MustEatLineBreak
AccessToken = ParseDeclarationArea(Entity) Set Token = AccessToken.Token
If Not Token.IsKeyword(kwEnd) Then Set Token = ParseProcedureArea(Entity, AccessToken) If Not Token.IsKeyword(kwEnd) Then Fail Token, Msg004, vEnd End If
Set Token = NextToken If Not Token.IsKeyword(IIf(Entity.IsClass, kwClass, kwModule)) Then Fail Token, Msg085 & NameBank(Mark)
Name = NameBank(Entity.Id.Name) If Source_.Entities.Exists(Name) Then Fail Entity.Id.Name, Msg006 & Name
Source_.Entities.AddKeyValue Name, Entity
MustEatLineBreak Loop End Sub
Private Function ParseDeclarationArea(ByVal Entity As Entity) As AccessToken Dim HadBase As Boolean Dim HadCompare As Boolean Dim Text As String Dim Token As Token Dim Access As Accessibility
Do Set Token = SkipLineBreaks
If Token.Kind = tkKeyword Then Select Case Token.Code Case kwOption If Access <> acLocal Then Fail Token, Msg009, Msg003 Set Token = NextToken If Token.Kind <> tkKeyword Then Fail Token, Msg015, vOption
Select Case Token.Code Case cxBase If HadBase Then Fail Token, Msg010
HadBase = True
Set Token = NextToken '''' Remove heading zeros ''''
Text = Token.Text
Do If Left$(Text, 1) <> "0"Then Exit Do
Text = Mid$(Text, 2) Loop
If Text = ""Then Text = "0" ''''''''''''''''''''''''''''''
If Token.Kind <> tkIntegerNumber Or (Text <> "0"And Text <> "1") Then
Fail Token, Msg011, "0 or 1" End If
Entity.OptionBase = IIf(Text = "0", 0, 1)
Case cxCompare If HadCompare Then Fail Token, Msg010
HadCompare = True
Set Token = NextToken If Token.Kind <> tkKeyword Then Fail Token, Msg013, Msg014
Select Case Token.Code Case cxBinary
Entity.OptionCompare = vbBinaryCompare
Case cxText
Entity.OptionCompare = vbTextCompare
Case Else
Fail Token, Msg013, Msg014 End Select
Case cxExplicit If Entity.OptionExplicit Then Fail Token, Msg010
Entity.OptionExplicit = True
Case Else
Fail Token, Msg015, vOption End Select
Case kwDefBool If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbBoolean, Entity
Case kwDefByte If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbByte, Entity
Case kwDefInt If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbInteger, Entity
Case kwDefLng If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbLong, Entity
Case kwDefLngLng If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbLongLong, Entity
Case kwDefLngPtr If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbLongPtr, Entity
Case kwDefCur If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbCurrency, Entity
Case kwDefDec If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbDecimal, Entity
Case kwDefSng If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbSingle, Entity
Case kwDefDbl If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbDouble, Entity
Case kwDefDate If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbDate, Entity
Case kwDefStr If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbString, Entity
Case kwDefObj If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbObject, Entity
Case kwDefVar If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseDef vbVariant, Entity
Case kwPublic, kwGlobal If Access <> acLocal Then Fail Token, Msg008, Msg003
Access = acPublic
Case kwPrivate If Access <> acLocal Then Fail Token, Msg008, Msg003
Access = acPrivate
Case kwConst If Access = acLocal Then Access = acPrivate
ParseConsts Access, Entity, Entity.Consts
Access = acLocal
Case kwEnum
ParseEnum Access, Entity
Access = acLocal
Case kwDeclare
ParseDeclare Access, Entity
Access = acLocal
Case kwEvent If Not Entity.IsClass Then Fail Token, Msg016 If Access = acLocal Then Access = acPublic If Access <> acPublic Then Fail Token, Msg017
ParseEvent Entity
Access = acLocal
Case kwImplements If Not Entity.IsClass Then Fail Token, Msg016 If Access <> acLocal Then Fail Token, Msg008, Msg003
ParseImplements Entity
Case kwWithEvents If Access = acLocal Then Access = acPublic
ParseDim Access, Entity, Entity.Vars, Token:=Token
Access = acLocal
Case kwDim If Access = acLocal Then Access = acPublic
ParseDim Access, Entity, Entity.Vars
Access = acLocal
Case kwType If Access = acLocal Then Access = acPublic
ParseType Access, Entity
Access = acLocal
Case kwFriend If Access <> acLocal Then Fail Token, Msg008, Msg003 If Not Entity.IsClass Then Fail Token, Msg016
Access = acFriend Exit Do
Case kwStatic, kwIterator, kwDefault, kwSub, kwFunction, cxProperty, kwEnd Exit Do
Case Else
Fail Token, Msg018 End Select
ElseIf Token.Kind = tkIdentifier And Token.Code = cxProperty Then
Token.Kind = tkKeyword Exit Do
With ParseDeclarationArea
.Access = Access Set .Token = Token End With End Function
Private Function ParseProcedureArea(ByVal Entity As Entity, ByRef AccessToken As AccessToken) As Token Dim IsDefault As Boolean Dim HadDefault As Boolean Dim IsIterator As Boolean Dim HadIterator As Boolean Dim IsStatic As Boolean Dim Token As Token Dim Proc As SubConstruct Dim Access As Accessibility Dim Func As FunctionConstruct Dim Prop As PropertyConstruct
Access = AccessToken.Access Set Token = AccessToken.Token
Do While Token.Kind = tkKeyword Select Case Token.Code Case kwPublic If Access <> acLocal Then Fail Token, Msg079, Msg003
Access = acPublic
Case kwPrivate If Access <> acLocal Then Fail Token, Msg079, Msg003
Access = acPrivate
Case kwFriend If Access <> acLocal Then Fail Token, Msg079, Msg003
Access = acFriend
Case kwDefault If IsDefault Or HadDefault Then Fail Token, Msg082
HadDefault = True
IsDefault = True
Case kwIterator If IsIterator Or HadIterator Then Fail Token, Msg081
HadIterator = True
IsIterator = True
Case kwStatic If IsStatic Then Fail Token, Msg080
IsStatic = True
Case kwSub Set Proc = ParseSub(Access, Entity)
Proc.IsDefault = IsDefault
Proc.IsStatic = IsStatic GoSub Cleanup
Case kwFunction Set Func = ParseFunction(Access, Entity)
Func.IsDefault = IsDefault
Func.IsStatic = IsStatic
Func.IsIterator = IsIterator If Func.IsDefault And Func.IsIterator Then Fail Token, Msg083 GoSub Cleanup
Case cxProperty Set Prop = ParseProperty(Access, Entity)
Prop.IsDefault = IsDefault
Prop.IsStatic = IsStatic GoSub Cleanup
Case Else Exit Do End Select
Set Token = SkipLineBreaks If Token.Kind = tkIdentifier And Token.Code = cxProperty Then Token.Kind = tkKeyword Loop
Set ParseProcedureArea = Token Exit Function
Cleanup:
IsStatic = False
IsDefault = False
IsIterator = False
Access = acLocal Return End Function
Private Sub ParseDef(ByVal VariableType As Integer, ByVal Entity As Entity) Dim First As String Dim Last As String Dim Token As Token Dim Mark As Token
Do Set Token = SkipLineBreaks Set Mark = Token
If Token.Kind <> tkIdentifier Then Fail Token, Msg019, Msg020 If Token.Suffix <> vbNullChar Then Fail Token, Msg060
First = NameBank(Token) Set Token = NextToken
If Token.IsOperator(opSubt) Then Set Token = NextToken If Token.Kind <> tkIdentifier Or Token.Suffix <> vbNullChar Then Fail Token, Msg019, Msg021
Last = NameBank(Token) Set Token = NextToken Else
Last = First End If
On Error Resume Next
Entity.DefTypes.SetRange First, Last, VariableType
If Err Then On Error GoTo 0
Fail Token, Msg022 End If
On Error GoTo 0
If IsBreak(Token) Then Exit Do If Token.Kind <> tkListSeparator Then Fail Token, Msg019, "," Loop End Sub
Private Function ParseConsts( _ ByVal Access As Accessibility, _ ByVal Entity As Entity, _ ByVal Body As KeyedList, _ Optional ByVal InsideProc As Boolean _
) As Token Dim Name As String Dim Token As Token Dim Cnt As ConstConstruct Dim Xp As New Expressionist
Do Rem Get Const's name Set Token = SkipLineBreaks If Not IsProperId(Token) Then Fail Token, Msg023, Msg003
Set Cnt = New ConstConstruct
Cnt.Access = Access Set Cnt.Id = NewId(Token)
Set Token = NextToken
Rem Do we have an As clause? If Token.IsKeyword(kwAs) Then If Token.Suffix <> vbNullChar Then Fail Token, Msg024
Rem Get Const's data type name Set Token = NextToken If Not IsConstDataType(Token) Then Fail Token, Msg023, Msg025
Set Cnt.DataType = NewDataType(Token) Set Token = NextToken
If Token.IsOperator(opMul) Then If Cnt.DataType.Id.Name <> vString Then Fail Token, Msg026
Set Cnt.DataType.FixedLength = Xp.GetExpression(Me) Set Token = Xp.LastToken If Cnt.DataType.FixedLength Is Nothing Then Fail Token, Msg065 End If
ElseIf Cnt.Id.Name.Suffix <> vbNullChar Then Rem Assign DataType property based on type sufix Set Cnt.DataType = FromChar(Cnt.Id.Name.Suffix) End If
Rem Discard "=" If Not Token.IsOperator(opEq) Then Fail Token, Msg023, "="
Rem Get Const's value Set Cnt.Value = Xp.GetExpression(Me) If Cnt.Value Is Nothing Then Fail Token, Msg065
Rem Ensure it's not a duplicated Const If Not InsideProc Then CheckDupl Entity, Cnt.Id.Name
Name = NameBank(Cnt.Id.Name) If Body.Exists(Name) Then Fail Cnt.Id.Name, Msg006 & Name
If Cnt.DataType Is Nothing Then Rem TODO: Infer its data type End If
Rem Save it
Body.AddKeyValue NameBank(Cnt.Id.Name), Cnt
Rem Move on Set Token = Xp.LastToken
If IsBreak(Token) Then Exit Do If InsideProc And Token.IsKeyword(kwElse) Then Exit Do
If Token.Kind <> tkListSeparator Then Fail Token, Msg023, Msg027 Loop
Set ParseConsts = Token End Function
Private Sub ParseEnum(ByVal Access As Accessibility, ByVal Entity As Entity) Dim Token As Token Dim Enm As EnumConstruct Dim Emd As EnumerandConstruct Dim Xp As New Expressionist
Set Token = NextToken If Not IsProperId(Token) Then Fail Token, Msg028, Msg003 If Token.Suffix <> vbNullChar Then Fail Token, Msg029
Set Enm = New EnumConstruct If Access = acLocal Then Access = acPublic
Enm.Access = Access Set Enm.Id = NewId(Token)
Set Token = NextToken If Not IsBreak(Token) Then Fail Token, Msg030, Msg031
Do Set Token = SkipLineBreaks If Token.IsKeyword(kwEnd) Then Exit Do If Not IsProperId(Token) Then Fail Token, Msg032, Msg003 If Token.Suffix <> vbNullChar Then Fail Token, Msg033
Set Emd = New EnumerandConstruct
Emd.Access = Access Set Emd.Id = NewId(Token)
Set Token = NextToken
If Token.IsOperator(opEq) Then Set Emd.Value = Xp.GetExpression(Me) Set Token = Xp.LastToken If Emd.Value Is Nothing Then Fail Token, Msg065 End If
If Enm.Enumerands.Exists(NameBank(Emd.Id.Name)) Then Fail Emd.Id, Msg006 & NameBank(Emd.Id.Name)
Enm.Enumerands.AddKeyValue NameBank(Emd.Id.Name), Emd Loop While IsBreak(Token)
If Not Token.IsKeyword(kwEnd) Then Fail Token, Msg034, vEnd
Set Token = NextToken If Not Token.IsKeyword(kwEnum) Then Fail Token, Msg034, vEnum
MustEatLineBreak
If Enm.Enumerands.Count = 0 Then Fail Enm, Msg035
CheckDupl Entity, Enm.Id.Name
Entity.Enums.AddKeyValue NameBank(Enm.Id.Name), Enm End Sub
Private Sub ParseDeclare(ByVal Access As Accessibility, ByVal Entity As Entity) Dim Token As Token Dim Tkn As Token Dim Dcl As DeclareConstruct
Set Dcl = New DeclareConstruct If Access = acLocal Then Access = acPublic
Dcl.Access = Access
Rem Is it PtrSafe? Set Token = NextToken
If Token.IsKeyword(kwPtrSafe) Then Rem Just ignore it Set Token = NextToken End If
Rem Is it a Sub or a Function? If Token.IsKeyword(kwSub) Then Rem It is a Sub
Dcl.IsSub = True
ElseIf Token.IsKeyword(kwFunction) Then Rem It is a Function
Dcl.IsSub = False 'Technically this is not needed.
Else Rem It is not a Sub nor a Function
Fail Token, Msg036, Msg037 End If
Rem Get its name. Set Token = NextToken If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, Msg036, Msg003
Set Dcl.Id = NewId(Token)
Rem Maybe there is a CDecl? Set Token = NextToken
If Token.IsKeyword(kwCDecl) Then
Dcl.IsCDecl = True Set Token = NextToken End If
Rem Discard Lib If Not Token.IsKeyword(cxLib) Then Fail Token, Msg036, vLib
Rem Get Lib's name Set Token = NextToken If Token.Kind <> tkString Then Fail Token, Msg036, Msg038 Set Dcl.LibName = Token
Rem Maybe there is an Alias? Set Token = NextToken
If Token.IsKeyword(cxAlias) Then Rem Get Alias' name Set Token = NextToken If Token.Kind <> tkString Then Fail Token, Msg036, Msg039
Set Dcl.AliasName = Token Set Token = NextToken End If
Rem Get its parameters. If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Entity, skDeclare, Dcl.Parameters)
Rem Maybe there's an "As" clause? If Token.IsKeyword(kwAs) Then Rem Can we have an "As" clause? If Dcl.IsSub Then Fail Token, Msg036, Msg031 If Token.Suffix <> vbNullChar Then Fail Token, Msg024
Rem Get data type name Set Token = NextToken
Select Case Token.Kind Case tkIdentifier, tkEscapedIdentifier If Token.Suffix <> vbNullChar Then Fail Token, Msg060 Set Dcl.DataType = NewDataType(Token) Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Not IsProperId(Token) Then Fail Token, Msg036, Msg025
Set Dcl.DataType.Id.Name = Token Set Token = NextToken End If
Case tkKeyword If Not IsBuiltinDataType(Token) Then Fail Token, Msg036, Msg025 Set Dcl.DataType = NewDataType(Token) Set Token = NextToken
Case Else
Fail Token, Msg036, Msg025 End Select
Rem Maybe it returns an array? If Token.Kind = tkLeftParenthesis Then Set Token = NextToken If Token.Kind <> tkRightParenthesis Then Fail Token, Msg036, Msg057 Debug.Assert Not Dcl.DataType Is Nothing
Dcl.DataType.IsArray = True
Set Token = NextToken End If End If
If Dcl.IsSub Then Set Tkn = New Token
Tkn.Kind = tkKeyword
Tkn.Code = kwVoid
Set Dcl.DataType = NewDataType(Tkn)
ElseIf Dcl.DataType Is Nothing Then If Dcl.Id.Name.Suffix = vbNullChar Then Set Dcl.DataType = Entity.DefTypes(NameBank(Dcl.Id.Name)) Else Set Dcl.DataType = FromChar(Dcl.Id.Name.Suffix) End If End If
Rem Ensure it is not duplicated.
CheckDupl Entity, Dcl.Id.Name
Rem Must end with a line break If Not IsBreak(Token) Then MustEatLineBreak
Entity.Declares.AddKeyValue NameBank(Dcl.Id.Name), Dcl End Sub
Private Function ParseParms(ByVal Entity As Entity, ByVal SignatureKind As SignatureKind, ByVal Parms As KeyedList) As Token Dim Count As Integer Dim Index As Integer Dim Name As String Dim Token As Token Dim LastParm As Parameter Dim CurrParm As Parameter Dim Xp As New Expressionist
Set LastParm = New Parameter Set Token = NextToken If Token.Kind = tkLeftParenthesis Then Set Token = NextToken
If Token.Kind <> tkRightParenthesis Then Do Set CurrParm = New Parameter
CurrParm.Index = Index
Index = Index + 1 If Index >= 60 Then Fail Token, Msg042
If Token.IsKeyword(kwOptional) Then If LastParm.IsParamArray Then Fail Token, Msg043 If SignatureKind = skEvent Or SignatureKind = skTuple Then Fail Token, Msg044
CurrParm.IsOptional = True Set Token = NextToken
ElseIf Token.IsKeyword(kwParamArray) Then If LastParm.IsOptional Then Fail Token, Msg043 If SignatureKind = skEvent Or SignatureKind = skTuple Then Fail Token, Msg045
CurrParm.IsParamArray = True Set Token = NextToken End If
If Not CurrParm.IsParamArray Then If Token.IsKeyword(kwByVal) Then If SignatureKind = skTuple Then Fail Token, Msg046
CurrParm.IsByVal = True Set Token = NextToken
ElseIf Token.IsKeyword(kwByRef) Then If SignatureKind = skTuple Then Fail Token, Msg047
CurrParm.IsByVal = False 'Technically this is not needed Set Token = NextToken End If End If
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, Msg041, Msg003 Set CurrParm.Id = NewId(Token)
Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = NextToken If Token.Kind <> tkRightParenthesis Then Fail Token, Msg041, ")"
CurrParm.IsArray = True Set Token = NextToken End If
If CurrParm.IsParamArray And Not CurrParm.IsArray Then Fail CurrParm.Id, Msg048
If Token.IsKeyword(kwAs) Then If CurrParm.Id.Name.Suffix <> vbNullChar Then Fail Token, Msg049 Set Token = NextToken
If SignatureKind = skDeclare Then If Not IsDataType(Token) Then Fail Token, Msg041, Msg025 Else If Not IsProperDataType(Token) Then Fail Token, Msg041, Msg025 End If
Set CurrParm.DataType = NewDataType(Token) Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Not IsProperId(Token) Then Fail Token, Msg050, Msg003
Set CurrParm.DataType.Id.Name = Token
If CurrParm.IsParamArray And ( _ Not CurrParm.DataType.Id.Project Is Nothing Or _
CurrParm.DataType.Id.Name.Code <> kwVariant) Then _
Fail Token, Msg051
Set Token = NextToken End If
ElseIf CurrParm.Id.Name.Suffix <> vbNullChar Then Set CurrParm.DataType = FromChar(CurrParm.Id.Name.Suffix)
Else Set CurrParm.DataType = Entity.DefTypes(NameBank(CurrParm.Id.Name)) End If
If Token.IsOperator(opEq) Then If Not CurrParm.IsOptional Then Fail Token, Msg053 If CurrParm.IsParamArray Then Fail Token, Msg054 Set CurrParm.Init = Xp.GetExpression(Me) Set Token = Xp.LastToken If CurrParm.Init Is Nothing Then Fail Token, Msg065 End If
If Not CurrParm.IsOptional And (LastParm.IsOptional Or LastParm.IsParamArray) Then If SignatureKind <> skPropertyLet And SignatureKind <> skPropertySet Then _
Fail CurrParm.Id, Msg041, vOptional
GoSub AddParm Set Token = NextToken Exit Do End If
GoSub AddParm Set LastParm = CurrParm If Token.Kind <> tkListSeparator Then Exit Do Set Token = NextToken Loop End If
If SignatureKind = skPropertyLet Or SignatureKind = skPropertySet Then If Parms.Count = 0 Then
Fail Token, Msg055
ElseIf LastParm.IsOptional Or LastParm.IsParamArray Then
Fail LastParm.Id, Msg056 End If End If
If Token.Kind <> tkRightParenthesis Then Fail Token, Msg057 Set ParseParms = NextToken Exit Function
AddParm:
Name = NameBank(CurrParm.Id.Name)
If Parms.Exists(Name) Then If SignatureKind <> skDeclare Then Fail CurrParm.Id, Msg040
Count = 1
Do
Name = NameBank(CurrParm.Id.Name) & "_" & CStr(Count) If Not Parms.Exists(Name) Then Exit Do
Count = Count + 1 Loop End If
Parms.AddKeyValue Name, CurrParm Return End Function
Private Sub ParseEvent(ByVal Entity As Entity) Dim Token As Token Dim Evt As EventConstruct
Set Token = SkipLineBreaks If Not IsProperId(Token) Then Fail Token, Msg012, Msg003
Set Evt = New EventConstruct Set Evt.Id = NewId(Token)
Set Token = NextToken If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Entity, skEvent, Evt.Parameters)
If Not IsBreak(Token) Then Fail Token, Msg012, Msg031
CheckDupl Entity, Evt.Id.Name
Entity.Events.AddKeyValue NameBank(Evt.Id.Name), Evt End Sub
Private Sub ParseImplements(ByVal Entity As Entity) Dim Name As String Dim Token As Token Dim Impls As ImplementsConstruct
Set Token = SkipLineBreaks If Token.Kind <> tkIdentifier Then Fail Token, Msg058, Msg059 If Token.Suffix <> vbNullChar Then Fail Token, Msg060
Set Impls = New ImplementsConstruct Set Impls.Id.Name = Token
Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Token.Kind <> tkIdentifier Then Fail Token, Msg058, Msg003 If Token.Suffix <> vbNullChar Then Fail Token, Msg060
Set Impls.Id.Name = Token Set Token = NextToken End If
If Not IsBreak(Token) Then Fail Token, Msg058, Msg031 Set Token = Impls.Id.Name
Name = NameBank(Token) If Entity.Impls.Exists(Name) Then Fail Token, Msg006 & Name
Entity.Impls.Add Impls, Name End Sub
Private Function ParseSub(ByVal Access As Accessibility, ByVal Entity As Entity) As SubConstruct Dim Name As String Dim Token As Token Dim Proc As SubConstruct
If Access = acLocal Then Access = acPublic Set Proc = New SubConstruct
Proc.Access = Access
Set Token = NextToken If Not IsProperId(Token) Then Fail Token, Msg069, Msg003
Set Proc.Id = NewId(Token) Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Entity, skSub, Proc.Parameters)
ElseIf Not IsBreak(Token) Then
Fail Token, Msg069, Msg031 End If
Set Token = ParseBody(Entity, Proc.Body) If Not Token.IsKeyword(kwSub) Then Fail Token, Msg072, vSub
MustEatLineBreak
Name = NameBank(Proc.Id.Name)
CheckDupl Entity, Proc.Id.Name
Entity.Subs.Add Proc, Name
Set ParseSub = Proc End Function
Private Function ParseFunction(ByVal Access As Accessibility, ByVal Entity As Entity) As FunctionConstruct Dim Name As String Dim Token As Token Dim Parm As Parameter Dim Func As FunctionConstruct
If Access = acLocal Then Access = acPublic Set Func = New FunctionConstruct
Func.Access = Access
Set Token = NextToken If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, Msg070, Msg003
Set Func.Id = NewId(Token)
Name = NameBank(Func.Id.Name)
Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Entity, skFunction, Func.Parameters)
ElseIf Not IsBreak(Token) Then
Fail Token, Msg070, Msg031 End If
For Each Parm In Func.Parameters If StrComp(Name, NameBank(Parm.Id.Name), vbTextCompare) = 0 Then Fail Parm.Id.Name, Msg075 Next
If Token.IsKeyword(kwAs) Then Set Token = NextToken If Not IsProperDataType(Token) Then Fail Token, Msg050, Msg059 Set Func.DataType = NewDataType(Token)
Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Not IsProperId(Token) Then Fail Token, Msg050, Msg003
Set Func.DataType.Id.Name = Token Set Token = NextToken End If
ElseIf Func.Id.Name.Suffix <> vbNullChar Then Set Func.DataType = FromChar(Func.Id.Name.Suffix)
Else Set Func.DataType = Entity.DefTypes(Name) End If
If Token.Kind = tkLeftParenthesis Then Set Token = NextToken If Token.Kind <> tkRightParenthesis Then Fail Token, Msg057
Func.DataType.IsArray = True End If
If Not IsBreak(Token) Then MustEatLineBreak Set Token = ParseBody(Entity, Func.Body) If Not Token.IsKeyword(kwFunction) Then Fail Token, Msg073, vFunction
MustEatLineBreak
CheckDupl Entity, Func.Id.Name
Entity.Functions.Add Func, Name
Set ParseFunction = Func End Function
Private Function ParseProperty(ByVal Access As Accessibility, ByVal Entity As Entity) As PropertyConstruct Dim IsNew As Boolean Dim Idx As Integer Dim Name As String Dim Token As Token Dim PropToken As Token Dim LeftParms As KeyedList Dim RightParms As KeyedList Dim Parm As Parameter Dim Kind As VbCallType Dim Slot As PropertySlot Dim Prop As PropertyConstruct
If Access = acLocal Then Access = acPublic Set Prop = New PropertyConstruct
Prop.Access = Access
Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail Token, Msg086
Select Case Token.Code Case kwGet
Kind = VbGet
Case kwLet
Kind = VbLet
Case kwSet
Kind = VbSet
Case Else
Fail Token, Msg071, Msg076 End Select
Set Token = NextToken If Not IsProperId(Token, CanHaveSuffix:=Kind = VbGet) Then Fail Token, Msg071, Msg003
Set PropToken = Token
Name = NameBank(Token)
CheckDupl Entity, Token, JumpProp:=True
If Entity.Properties.Exists(Name) Then Set Slot = Entity.Properties(Name) Else
IsNew = True Set Slot = New PropertySlot Set Slot.Id = NewId(Token) End If
Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms( _
Entity, _
Switch(Kind = VbGet, skPropertyGet, Kind = VbLet, skPropertyLet, True, skPropertySet), _
Prop.Parameters _
)
ElseIf Not IsBreak(Token) Then
Fail Token, Msg071, Msg031 End If
If Kind = VbGet Then For Each Parm In Prop.Parameters If StrComp(Name, NameBank(Parm.Id.Name), vbTextCompare) = 0 Then Fail Parm.Id.Name, Msg075 Next
If Token.IsKeyword(kwAs) Then Set Token = NextToken If Not IsProperDataType(Token) Then Fail Token, Msg050, Msg059 Set Slot.DataType = NewDataType(Token)
Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Not IsProperId(Token) Then Fail Token, Msg050, Msg003
Set Slot.DataType.Id.Name = Token Set Token = NextToken End If
ElseIf Slot.Id.Name.Suffix <> vbNullChar Then Set Slot.DataType = FromChar(Slot.Id.Name.Suffix)
Else Set Slot.DataType = Entity.DefTypes(Name) End If
If Token.Kind = tkLeftParenthesis Then Set Token = NextToken If Token.Kind <> tkRightParenthesis Then Fail Token, Msg057
Slot.DataType.IsArray = True End If
ElseIf Prop.Parameters.Count = 0 Then
Fail Slot.Id.Name, Msg078 End If
If Kind = VbSet Then If IsBuiltinDataType(Prop.Parameters(Prop.Parameters.Count).Id.Name) Then Fail Slot.Id.Name, Msg077 End If
Set Token = ParseBody(Entity, Prop.Body) If Token.Kind <> tkIdentifier Or Token.Code <> cxProperty Then Fail Token, Msg074
MustEatLineBreak
If IsNew Then
Entity.Properties.Add Slot, Name
ElseIf Slot.Exists(Kind) Then
Fail PropToken, Msg006 & Name End If
Slot.Add Kind, Prop
If Kind <> VbGet Then Set Parm = Prop.Parameters(Prop.Parameters.Count) If Parm.IsOptional Then Fail Slot.Id.Name, Msg077 If Parm.IsParamArray Then Fail Slot.Id.Name, Msg077 End If
If Slot.Exists(VbGet) And Slot.Exists(VbLet) Then Set LeftParms = Slot(VbGet).Parameters Set RightParms = Slot(VbLet).Parameters If LeftParms.Count + 1 <> RightParms.Count Then Fail Slot.Id.Name, Msg077
For Idx = 1 To LeftParms.Count If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail LeftParms(Idx).Id.Name, Msg075 Next
If Kind = VbGet Then If Slot.DataType.IsArray <> RightParms(RightParms.Count).DataType.IsArray Then Fail Slot.Id.Name, Msg077 If Slot.DataType.Id.Name.Code <> RightParms(RightParms.Count).DataType.Id.Name.Code Then _
Fail Slot.Id.Name, Msg077 End If End If
If Slot.Exists(VbGet) And Slot.Exists(VbSet) Then Set LeftParms = Slot(VbGet).Parameters Set RightParms = Slot(VbSet).Parameters If LeftParms.Count + 1 <> RightParms.Count Then Fail Slot.Id.Name, Msg077
For Idx = 1 To LeftParms.Count If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail Slot.Id.Name, Msg077 Next End If
If Slot.Exists(VbLet) And Slot.Exists(VbSet) Then Set LeftParms = Slot(VbLet).Parameters Set RightParms = Slot(VbSet).Parameters If LeftParms.Count <> RightParms.Count Then Fail Slot.Id.Name, Msg077
For Idx = 1 To LeftParms.Count - 1 If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail Slot.Id.Name, Msg077 Next End If
Set ParseProperty = Prop 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 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 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
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 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 Set LookAhead = ParseFor(Entity, Body)
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
ParseWhile Entity, Body
Case cxWidth GoSub DiscardLine
Case kwWith
ParseWith Entity, Body
Case kwWrite GoSub DiscardLine
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, Msg094
Body.Add Stmt End Select
Case tkDirective GoSub DiscardLine
Case tkOperator Select Case Token.Code Case opWithBang, opWithDot GoSub DiscardLine
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
Set ParseBody = Token Exit Function
DiscardLine: Do Set Token = NextToken Loop Until IsBreak(Token)
Return 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
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 Sub ParseType(ByVal Access As Accessibility, ByVal Entity As Entity) Dim Name As String Dim Token As Token Dim Ent As Entity Dim Var As Variable Dim Typ As TypeConstruct
Set Ent = New Entity Set Typ = New TypeConstruct
Typ.Access = Access
Set Token = NextToken If Not IsProperId(Token) Then Fail Token, Msg066, Msg003
Set Typ.Id = NewId(Token)
MustEatLineBreak Set Token = Nothing 'Force ParseDim to get next token
Do
ParseDim acLocal, Ent, Ent.Vars, Token:=Token Rem Should not have "A As Boolean, B As ... If Ent.Vars.Count > 1 Then Fail Ent.Vars(2).Id.Name, Msg067, Msg031
Set Var = Ent.Vars(1) Rem Must have an explicit data type. If Var.DataType.Id.Name.Line = 0 Then Fail Var.DataType.Id.Name, Msg067, vAs
Rem Must not have an initial value If Not Var.Init Is Nothing Then Fail Var.Init, Msg067, Msg031
Ent.Vars.Clear
Name = NameBank(Var.Id.Name) If Typ.Members.Exists(Name) Then Fail Var.Id.Name, Msg006 & Name
Typ.Members.Add Var, Name Set Token = SkipLineBreaks Loop Until Token.IsKeyword(kwEnd)
Set Token = NextToken If Not Token.IsKeyword(kwType) Then Fail Token, Msg068, vType
Name = NameBank(Typ.Id.Name)
CheckDupl Entity, Var.Id.Name
Entity.Types.Add Typ, Name End Sub
Private Function IsStatement(ByVal Token As Token) As Boolean Select Case Token.Kind Case tkOperator
IsStatement = Token.Code = opWithBang Or Token.Code = opWithDot
Case tkIdentifier, tkEscapedIdentifier, tkKeyword
IsStatement = True End Select End Function
Private Function ParseIf(ByVal Entity As Entity, ByVal Body As KeyedList) As Token Dim Arm As IfArm Dim Token As Token Dim Stmt As IfConstruct Dim Xp As Expressionist
Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt = New IfConstruct
Set Arm = New IfArm Rem If <condition> ? Set Token = NextToken Set Arm.Condition = Xp.GetExpression(Me, Token) If Arm.Condition Is Nothing Then Fail Token, Msg065
Rem If <condition> Then ? Set Token = Xp.LastToken If Not Token.IsKeyword(kwThen) Then Fail Token, Msg088, NameBank.Keywords(kwThen)
Stmt.Arms.Add Arm Set Token = NextToken
If Token.Kind = tkSoftLineBreak Then Rem If <condition> Then : Do Set Token = NextToken If IsHardBreak(Token) Then Exit Do
Up: If Not IsStatement(Token) Then Fail Token, Msg087
Rem If <condition> Then : <statement> Set Token = ParseBody(Entity, Arm.Body, IsSingleLine:=True, LookAhead:=Token) Loop While Token.Kind = tkSoftLineBreak
If Token.IsKeyword(kwElse) Then Rem If <condition> Then : <statement> Else Set Token = NextToken
Do If Token.Kind = tkSoftLineBreak Then Set Token = NextToken If Not IsStatement(Token) Then Fail Token, Msg087
Set Token = ParseBody(Entity, Stmt.ElseBody, IsSingleLine:=True, LookAhead:=Token) Loop While Token.Kind = tkSoftLineBreak End If
If Not IsHardBreak(Token) Then Fail Token, Msg031
ElseIf IsHardBreak(Token) Then Set Token = ParseBody(Entity, Arm.Body) If Token.Kind <> tkKeyword Then Fail Token, Msg089
Do Select Case Token.Code Case kwElseIf Set Arm = New IfArm Set Arm.Condition = Xp.GetExpression(Me) If Arm.Condition Is Nothing Then Fail Token, Msg065
Set Token = Xp.LastToken If Not Token.IsKeyword(kwThen) Then Fail Token, Msg088, NameBank.Keywords(kwThen)
Set Token = ParseBody(Entity, Arm.Body)
Stmt.Arms.Add Arm
Case kwElse Set Token = NextToken If Not IsHardBreak(Token) Then Fail Token, Msg027
Set Token = ParseBody(Entity, Stmt.ElseBody)
If Token.IsKeyword(kwIf) Then Set Token = NextToken Exit Do End If
Fail Token, Msg085 & NameBank.Keywords(kwIf)
Case kwIf Set Token = NextToken Exit Do
Case Else
Fail Token, Msg089 End Select Loop
ElseIf IsStatement(Token) Then GoTo Up
Else
Fail Token, Msg090 End If
Body.Add Stmt Set ParseIf = Token End Function
Private Sub ParseSelect(ByVal Entity As Entity, ByVal Body As KeyedList) Dim Token As Token Dim Expr As IExpression Dim Xp As Expressionist Dim Cs As CaseConstruct Dim Stmt As SelectConstruct Dim IsExpr As BinaryExpression
Set Xp = New Expressionist
Xp.FullMode = True Set Stmt = New SelectConstruct
Set Token = NextToken If Not Token.IsKeyword(kwCase) Then Fail Token, Msg091, NameBank.Keywords(kwCase)
Set Stmt.Value = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.Value Is Nothing Then Fail Token, Msg065 If Not IsBreak(Token) Then Fail Token, Msg031
Rem From now on we'll accept the "To" operator
Xp.CanHaveTo = True
Do Rem We can have a "look-ahead" token Case from ParseBody below. Rem After parsing the statement block it may have stumbled upon "Case Else", for instance. If Not Token.IsKeyword(kwCase) Then Set Token = SkipLineBreaks
Rem We will have this situation if there's an empty Select Case like: Rem Select Case Abc Rem End Select If Token.IsKeyword(kwEnd) Then Set Token = NextToken If Token.IsKeyword(kwSelect) Then Exit Do
Fail Token, Msg085 & NameBank.Keywords(kwSelect) End If
Debug.Assert Token.IsKeyword(kwCase) Set Cs = New CaseConstruct
Do Set Expr = Xp.GetExpression(Me) Set Token = Xp.LastToken
If Expr Is Nothing Then If Token.IsOperator(opIs) Then Rem We have an "Is" expression Set IsExpr = New BinaryExpression 'IsExpr.LHS will be Nothing
Set Token = NextToken If Token.Kind <> tkOperator Then Fail Token, Msg092
Set IsExpr.Operator = NewOperator(Token) If IsExpr.Operator.IsUnary Then Fail Token, Msg092
Set IsExpr.RHS = Xp.GetExpression(Me) Set Token = Xp.LastToken If IsExpr.RHS Is Nothing Then Fail Token, Msg065
Set Expr = IsExpr
ElseIf Token.IsKeyword(kwElse) Then Rem We have a "Case Else". Set Token = ParseBody(Entity, Stmt.CaseElse) If Not Token.IsKeyword(kwSelect) Then Fail Token, Msg085 & NameBank.Keywords(kwSelect)
Rem Cs must not be added after Loop Set Cs = Nothing Exit Do
Else Debug.Assert False
Fail Token, Msg093 End If End If
Cs.Conditions.Add Expr
If IsBreak(Token) Then Set Token = ParseBody(Entity, Cs.Body) Exit Do End If
If Token.Kind <> tkListSeparator Then Fail Token, Msg027 Loop
If Not Cs Is Nothing Then Stmt.Cases.Add Cs Loop Until Token.IsKeyword(kwSelect)
Body.Add Stmt End Sub
Private Sub ParseWith(ByVal Entity As Entity, ByVal Body As KeyedList) Dim Token As Token Dim Stmt As WithConstruct Dim Xp As Expressionist
Set Xp = New Expressionist
Xp.FullMode = True Set Stmt = New WithConstruct
Set Token = NextToken If Not IsProperId(Token) Then Fail Token, Msg095, Msg096
Set Stmt.PinObject = Xp.GetStmt(Me, Token) Set Token = Xp.LastToken If Stmt.PinObject Is Nothing Then Fail Token, Msg095, Msg096
Set Token = ParseBody(Entity, Stmt.Body, LookAhead:=Token) If Not Token.IsKeyword(kwWith) Then Fail Token, Msg085 & vWith
Body.Add Stmt End Sub
Private Function AreEqual(ByVal LeftParm As Parameter, ByVal RightParm As Parameter) As Boolean If LeftParm.IsArray <> RightParm.IsArray Then Exit Function If LeftParm.IsByVal <> RightParm.IsByVal Then Exit Function If LeftParm.IsOptional <> RightParm.IsOptional Then Exit Function If LeftParm.IsParamArray <> RightParm.IsParamArray Then Exit Function If LeftParm.DataType.Id.Name.Code <> RightParm.DataType.Id.Name.Code Then Exit Function
AreEqual = True End Function
Private Function SynthLower(ByVal Entity As Entity) As IExpression Dim Token As Token Dim Lit As Literal
Set Token = New Token
Token.Kind = tkIntegerNumber
Token.Text = CStr(Entity.OptionBase)
Set Lit = New Literal Set Lit.Value = Token
Set SynthLower = Lit End Function
Private Sub MustEatLineBreak() Dim Token As Token
Set Token = NextToken If IsBreak(Token) Then Exit Sub If Token.Kind = tkComment Then Exit Sub
Fail Token, Msg005, Msg031 End Sub
Private Function SkipLineBreaks() As Token Dim Token As Token
Do Set Token = NextToken Loop While Token.Kind = tkSoftLineBreak Or Token.Kind = tkHardLineBreak Or Token.Kind = tkComment
Set SkipLineBreaks = Token End Function
Private Function IsId(ByVal Token As Token, Optional ByVal CanHaveSuffix As Boolean) As Boolean If Not CanHaveSuffix And Token.Suffix <> vbNullChar Then Fail Token, Msg060
IsId = Token.Kind = tkIdentifier Or Token.Kind = tkEscapedIdentifier End Function
Private Function IsProperId(ByVal Token As Token, Optional ByVal CanHaveSuffix As Boolean) As Boolean Const ASCII_US = 95 Const ASCII_ZERO = 46 Const ASCII_NINE = 57
Dim IsOK As Boolean Dim Pos As Integer Dim Cp As Integer Dim Text As String
If Not CanHaveSuffix And Token.Suffix <> vbNullChar Then Fail Token, Msg060
If Token.Kind = tkIdentifier Then
IsProperId = True Exit Function End If
If Token.Kind <> tkEscapedIdentifier Then Exit Function
Text = NameBank(Token)
For Pos = 1 To Len(Text)
Cp = AscW(Mid$(Text, Pos, 1))
IsOK = Cp = ASCII_US If Not IsOK Then IsOK = Cp >= ASCII_ZERO And Cp <= ASCII_NINE If Not IsOK Then IsOK = IsLetter(Cp) If Not IsOK Then IsOK = IsSurrogate(Cp) If Not IsOK Then Exit Function Next
IsProperId = True End Function
Friend Function IsHardBreak(ByVal Token As Token) As Boolean
IsHardBreak = Token.Kind = tkHardLineBreak Or Token.Kind = tkComment End Function
Friend Function IsBreak(ByVal Token As Token) As Boolean
IsBreak = Token.Kind = tkSoftLineBreak Or Token.Kind = tkHardLineBreak Or Token.Kind = tkComment End Function
Private Function IsProperDataType(ByVal Token As Token) As Boolean If Token.Suffix <> vbNullChar Then Fail Token, Msg060
Select Case Token.Kind Case tkIdentifier
IsProperDataType = True
Case tkEscapedIdentifier
IsProperDataType = IsProperId(Token)
Case tkKeyword
IsProperDataType = IsBuiltinDataType(Token) End Select End Function
Private Function IsConstDataType(ByVal Token As Token) As Boolean Select Case Token.Code Case kwBoolean, kwByte, kwInteger, kwLong, kwLongLong, kwLongPtr, kwCurrency, cxDecimal, _
kwSingle, kwDouble, kwDate, kwString
IsConstDataType = True End Select End Function
Private Function IsBuiltinDataType(ByVal Token As Token) As Boolean Select Case Token.Code Case cxObject, kwVariant
IsBuiltinDataType = True
Case Else
IsBuiltinDataType = IsConstDataType(Token) End Select End Function
Private Function IsDataType(ByVal Token As Token) As Boolean If Token.Suffix <> vbNullChar Then Fail Token, Msg060
If Token.IsKeyword(kwAny) Then
IsDataType = True Exit Function End If
IsDataType = IsProperDataType(Token) End Function
Private Function IsEndOfContext(ByVal Token As Token) As Boolean Dim Result As Boolean
Result = IsBreak(Token) If Not Result Then Result = Token.Kind = tkRightParenthesis If Not Result Then Result = Token.Kind = tkListSeparator If Not Result Then Result = Token.Kind = tkPrintSeparator
If Not Result And Token.Kind = tkKeyword Then
Result = Token.Code = kwThen If Not Result Then Result = Token.Code = kwElse End If
If Not Result Then Result = Token.Kind = tkIdentifier And Token.Code = cxStep
IsEndOfContext = Result End Function
Friend Sub Fail(ByVal Token As Token, ByVal Message As String, Optional ByVal Expected As String) Dim Ch As Integer Dim Msg As String Dim Got As String Dim Text As String
Select Case Token.Kind Case tkEscapedIdentifier
Got = "[" & NameBank(Token) & "]"
Case tkFileHandle, tkDirective
Got = "#" & NameBank(Token)
Private Function FromChar(ByVal TypeDeclarationChar As String) As DataType Dim Token As Token
Set Token = New Token
Token.Kind = tkKeyword
Select Case TypeDeclarationChar Case"%"
Token.Code = kwInteger
Case"&"
Token.Code = kwLong
Case"^"
Token.Code = kwLongLong
Case"@"
Token.Code = kwCurrency
Case"!"
Token.Code = kwSingle
Case"#"
Token.Code = kwDouble
Case"$"
Token.Code = kwString
Case Else Debug.Assert False End Select
Set FromChar = NewDataType(Token) End Function
Private Sub CheckDupl(ByVal Entity As Entity, ByVal Token As Token, Optional ByVal JumpProp As Boolean) Dim Name As String
Name = NameBank(Token)
With Entity If .Consts.Exists(Name) Then Fail Token, Msg006 & Name If .Enums.Exists(Name) Then Fail Token, Msg006 & Name If .Declares.Exists(Name) Then Fail Token, Msg006 & Name If .Events.Exists(Name) Then Fail Token, Msg006 & Name If .Impls.Exists(Name) Then Fail Token, Msg006 & Name If .Vars.Exists(Name) Then Fail Token, Msg006 & Name If .Types.Exists(Name) Then Fail Token, Msg006 & Name If .Subs.Exists(Name) Then Fail Token, Msg006 & Name If .Functions.Exists(Name) Then Fail Token, Msg006 & Name If Not JumpProp Then If .Properties.Exists(Name) Then Fail Token, Msg006 & Name End With End Sub
Private Sub ParseDo(ByVal Entity As Entity, ByVal Body As KeyedList) Dim Token As Token Dim Mark As Token Dim Stmt As DoConstruct Dim Xp As Expressionist
Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt = New DoConstruct Set Token = NextToken Set Mark = Token
If Token.IsKeyword(kwWhile) Then
Stmt.DoType = dtDoWhileLoop Set Stmt.Condition = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.Condition Is Nothing Then Fail Mark, Msg065
ElseIf Token.IsKeyword(kwUntil) Then
Stmt.DoType = dtDoUntilLoop Set Stmt.Condition = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.Condition Is Nothing Then Fail Mark, Msg065 End If
If Not IsBreak(Token) Then Fail Token, Msg031 Set Token = ParseBody(Entity, Stmt.Body)
If Not Token.IsKeyword(kwLoop) Then Fail Token, Msg097
Set Token = NextToken
If Stmt.DoType = dtNone Then If Token.IsKeyword(kwWhile) Then
Stmt.DoType = dtDoLoopWhile Set Stmt.Condition = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.Condition Is Nothing Then Fail Mark, Msg065
ElseIf Token.IsKeyword(kwUntil) Then
Stmt.DoType = dtDoUntilLoop Set Stmt.Condition = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.Condition Is Nothing Then Fail Mark, Msg065 End If End If
If Not IsBreak(Token) Then Fail Token, Msg031
Body.Add Stmt End Sub
Private Function ParseFor(ByVal Entity As Entity, ByVal Body As KeyedList) As Token Dim Token As Token Dim Lit As Literal Dim Expr As IExpression Dim Stmt As ForConstruct Dim Xp As Expressionist Dim Bin As BinaryExpression
Set Xp = New Expressionist
Xp.FullMode = True
Xp.CanHaveTo = True Set Token = NextToken
If Token.IsKeyword(kwEach) Then
ParseForEach Entity, Body Exit Function End If
Set Stmt = New ForConstruct If Not IsProperId(Token) Then Token, Msg098, Msg003
Set Stmt.Counter = New Symbol Set Stmt.Counter.Value = Token
Set Token = NextToken If Not Token.IsOperator(opEq) Then Fail Token, Msg098, "="
Set Expr = Xp.GetExpression(Me) Set Token = Xp.LastToken
If Expr Is Nothing Then Fail Mark, Msg065 If Expr.Kind <> ekBinaryExpr Then Fail Mark, Msg065 Set Bin = Expr If Not Bin.Operator.Value.Code = opTo Then Fail Token, Msg098, vTo
Set Stmt.StartValue = Bin.LHS Set Stmt.EndValue = Bin.RHS
If Token.Kind = tkIdentifier And Token.Code = cxStep Then
Xp.CanHaveTo = False Set Stmt.Increment = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.Increment Is Nothing Then Fail Mark, Msg098, Msg099 Else Set Lit = New Literal Set Lit.Value = New Token
Lit.Value.Kind = tkIntegerNumber
Lit.Value.Text = "1" Set Stmt.Increment = Lit End If
If Not IsBreak(Token) Then Fail Token, Msg031 Set Token = ParseBody(Entity, Stmt.Body)
If Token.IsKeyword(kwNext) Then Set Token = NextToken
If IsProperId(Token) And Token.Code = Stmt.Counter.Value.Code Then Set Token = NextToken
If Token.Kind = tkListSeparator Then Set Token = New Token
Token.Kind = tkKeyword
Token.Code = kwNext
ElseIf IsBreak(Token) Then Rem OK
Else
Fail Token, Msg031 End If
ElseIf IsBreak(Token) Then Rem OK
Else Stop End If
Else
Fail Token, Msg031 End If
Body.Add Stmt Set ParseFor = Token End Function
Private Sub ParseForEach(ByVal Entity As Entity, ByVal Body As KeyedList) Dim Token As Token Dim Stmt As ForEachConstruct Dim Xp As Expressionist
Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt = New ForEachConstruct Set Token = NextToken If Not IsProperId(Token) Then Fail Token, Msg100, Msg001
Set Stmt.Element = New Symbol Set Stmt.Element.Value = Token
Set Token = NextToken If Not Token.IsKeyword(kwIn) Then Token, Msg100, vIn
Set Token = NextToken If Not IsProperId(Token) Then Fail Token, Msg100, Msg102 Set Stmt.Group = Xp.GetStmt(Me, Token) If Stmt.Group Is Nothing Then Fail Token, Msg100, Msg102
Set Token = Xp.LastToken If Not IsBreak(Token) Then Fail, Token, Msg031
Set Token = ParseBody(Entity, Stmt.Body) If Not Token.IsKeyword(kwNext) Then Fail Token, Msg103
MustEatLineBreak
Body.Add Stmt End Sub
Private Sub ParseWhile(ByVal Entity As Entity, ByVal Body As KeyedList) Dim Token As Token Dim Xp As Expressionist Dim Stmt As WhileConstruct
Set Xp = New Expressionist
Xp.FullMode = True Set Stmt = New WhileConstruct
Set Stmt.Condition = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.Condition Is Nothing Then Fail Token, Msg065
If Not IsBreak(Token) Then Fail Token, Msg031 Set Token = ParseBody(Entity, Stmt.Body)
If Token.IsKeyword(kwWend) Then Rem OK
ElseIf Token.IsKeyword(kwWhile) Then Rem OK
Else
Fail Token, Msg104 End If
MustEatLineBreak
Body.Add Stmt End Sub End Class
Public Class PrintConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snPrint End Property End Class
Public Class PropertyConstruct Option Explicit
Private Parms_ As KeyedList Private Body_ As KeyedList
Public Access As Accessibility Public IsStatic As Boolean Public IsDefault As Boolean
Private Sub Class_Initialize() Set Parms_ = New KeyedList Set Parms_.T = NewValidator(TypeName(New Parameter))
Parms_.CompareMode = vbTextCompare
Set Body_ = New KeyedList Set Body_.T = New StmtValidator End Sub
Public Property Get Parameters() As KeyedList Set Parameters = Parms_ End Property
Public Static Property Get Body() As KeyedList Set Body = Body_ End Property End Class
Public Class PropertySlot Option Explicit
Private PropertyGet_ As PropertyConstruct Private PropertyLet_ As PropertyConstruct Private PropertySet_ As PropertyConstruct
Public Id As Identifier Public DataType As DataType
Public Sub Add(ByVal Kind As VbCallType, ByVal Item As PropertyConstruct) Select Case Kind Case VbGet If Not PropertyGet_ Is Nothing Then Err.Raise 457 Set PropertyGet_ = Item
Case VbLet If Not PropertyLet_ Is Nothing Then Err.Raise 457 Set PropertyLet_ = Item
Case VbSet If Not PropertySet_ Is Nothing Then Err.Raise 457 Set PropertySet_ = Item
Case Else Debug.Assert False End Select End Sub
Public Default Property Get Item(ByVal Kind As VbCallType) As PropertyConstruct Select Case Kind Case VbGet Set Item = PropertyGet_
Case VbLet Set Item = PropertyLet_
Case VbSet Set Item = PropertySet_
Case Else Debug.Assert False End Select End Property
Public Property Get Exists(ByVal Kind As VbCallType) As Boolean Select Case Kind Case VbGet
Exists = Not PropertyGet_ Is Nothing
Case VbLet
Exists = Not PropertyLet_ Is Nothing
Case VbSet
Exists = Not PropertySet_ Is Nothing
Case Else Debug.Assert False End Select End Property End Class
Public Class PutConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snPut End Property End Class
Public Class RaiseEventConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snRaiseEvent End Property End Class
Public Class ReDimConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snReDim End Property End Class
Public Class ResetConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snReset End Property End Class
Public Class ResumeConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snResume End Property End Class
Public Class ReturnConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snReturn End Property End Class
Public Class Reverter Option Explicit
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
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
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 "("
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
Builder.Append ")" End If 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)
Builder.Append "Do"
Select Case Stmt.DoType Case dtDoWhileLoop
Builder.Append " While "
EmitExpression Stmt.Condition
Case dtDoUntilLoop
Builder.Append " Until "
EmitExpression Stmt.Condition End Select
Builder.AppendLn
Builder.Indent
EmitBody Stmt.Body
Builder.Deindent
Builder.Append "Loop"
Select Case Stmt.DoType Case dtDoLoopWhile
Builder.Append " While "
EmitExpression Stmt.Condition
Case dtDoLoopUntil
Builder.Append " Until "
EmitExpression Stmt.Condition End Select 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) Dim Lit As Literal Dim HasStep As Boolean
If Stmt.Increment.Kind = ekLiteral Then: Set Lit = Stmt.Increment: HasStep = Lit.Value.Line <> 0 Or Lit.Value.Column <> 0
If HasStep Then
Builder.Append " Step "
EmitExpression Stmt.Increment End If
Builder.AppendLn
Builder.Indent
EmitBody Stmt.Body
Builder.Deindent
Builder.Append "Next" End Sub
Private Sub EmitForEach(ByVal Stmt As ForEachConstruct)
Builder.Append "For Each "
EmitToken Stmt.Element.Value
Builder.Append " In "
EmitExpression Stmt.Group
Builder.AppendLn
Builder.Indent
EmitBody Stmt.Body
Builder.Deindent
Builder.Append "Next" 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) 'Builder.Append "Let "
EmitExpression Stmt.Name
EmitOperator Stmt.Operator
EmitExpression Stmt.Value End Sub
Private Sub EmitLineNumber(ByVal Stmt As LineNumberConstruct)
EmitToken Stmt.Value 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)
Builder.Append "Reset" 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)
Builder.Append "While "
EmitExpression Stmt.Condition
Builder.AppendLn
Builder.Indent
EmitBody Stmt.Body
Builder.Deindent
Builder.Append "Wend" End Sub
Private Sub EmitWidth(ByVal Stmt As WidthConstruct) Stop End Sub
Private Sub EmitWith(ByVal Stmt As WithConstruct)
Builder.Append "With "
EmitExpression Stmt.PinObject
Builder.AppendLn
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
Err.Raise 5 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
Public Class RSetConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snRSet End Property End Class
Public Class Scanner Option Explicit
Private Const Msg_ = "Invalid literal"
Private Const LF_ As Integer = 10 'Line feed Private Const CR_ As Integer = 13 'Carriage return Private Const SP_ As Integer = 32 'Space Private Const US_ As Integer = 95 'Underscore Private Const BS_ As Integer = 8 'Backspace. Used for line continuation Private Const CRLF_ As Long = &HA000D
Private File_ As Integer Private RunningLine_ As Long Private RunningColumn_ As Long Private FrozenColumn_ As Long Private PreviousColumn_ As Long Private FilePath_ As String
Select Case Ch Case"[" Set Token = ReadEscapedIdentifier
Case"""" Set Token = ReadString
Case"&" Set Token = ReadAmpersand
Case"#" Set Token = ReadHash
Case"0"To"9" Set Token = ReadNumber(Ch)
Case"+" Set Token = NewToken(tkOperator, opSum)
Case"-" Set Token = NewToken(tkOperator, opSubt)
Case"*" Set Token = NewToken(tkOperator, opMul)
Case"/" Set Token = NewToken(tkOperator, opDiv)
Case"\" Set Token = NewToken(tkOperator, opIntDiv)
Case"^" Set Token = NewToken(tkOperator, opPow)
Case"=" Set Token = NewToken(tkOperator, opEq)
Case"." Set Token = NewToken(tkOperator, opDot)
Case"!" Set Token = NewToken(tkOperator, opBang)
Case"<" Set Token = NewToken(tkOperator, opLt)
If Not AtEnd Then
Ch = GetChar
Select Case Ch Case">"
Token.Code = opNe
Case"="
Token.Code = opLe
Case"<"
Token.Code = opLSh
Case Else
UngetChar Ch End Select End If
Case">" Set Token = NewToken(tkOperator, opGt)
If Not AtEnd Then
Ch = GetChar
Select Case Ch Case"="
Token.Code = opGe
Case">"
Token.Code = opRSh
If Not AtEnd Then
Ch = GetChar
If Ch = ">"Then
Token.Code = opURSh Else
UngetChar Ch End If End If
Case Else
UngetChar Ch End Select End If
Case":" Set Token = NewToken(tkSoftLineBreak)
If Not AtEnd Then
Ch = GetChar
If Ch = "="Then
Token.Kind = tkOperator
Token.Code = opNamed Else
UngetChar Ch End If End If
Case vbLf Set Token = NewToken(tkHardLineBreak)
Case"'" Set Token = ReadComment
Case"," Set Token = NewToken(tkListSeparator)
Case";" Set Token = NewToken(tkPrintSeparator)
Case"(" Set Token = NewToken(tkLeftParenthesis)
Case")" Set Token = NewToken(tkRightParenthesis)
Case" " Set Token = NewToken(tkWhiteSpace)
Case vbBack Set Token = NewToken(tkLineContinuation)
Case"`"
Done = False
DiscardComment Set Token = New Token
Case Else If Not IsLetter(Cp) Then Fail "Invalid token: '" & Ch & "'"
Set Token = ReadIdentifier(Cp)
If Token.Kind = tkKeyword Then If Token.Code = kwRem Then Set Token = ReadComment(IsRem:=True)
ElseIf Token.Kind = tkOperator Then If Not AtEnd Then
Ch = GetChar
If Ch = "="Then Select Case Token.Code Case opAnd, opEqv, opImp, opMod, opOr, opXor
Token.Code = Token.Code + opCompAnd - opAnd
Case Else
UngetChar Ch End Select Else
UngetChar Ch End If End If End If End Select
Select Case Token.Code Case opSum, opSubt, opMul, opDiv, opIntDiv, opPow If Not AtEnd Then
Ch = GetChar
If Ch = "="Then
Token.Code = Token.Code + opCompSum - opSum Else
UngetChar Ch End If End If End Select Loop Until Done
Set GetToken = Token End Function
Private Function GetCodePoint() As Integer Dim CheckLF As Boolean Dim Cp1 As Integer Dim Cp2 As Integer Dim Cp3 As Integer
Cp1 = NextCodePoint If IsSpace(Cp1) Then Cp1 = SP_
Select Case Cp1 Case SP_
Cp2 = NextCodePoint
If Cp2 = US_ Then
Cp3 = NextCodePoint
Select Case Cp3 Case CR_
CheckLF = True
AdvanceLine
Cp1 = BS_
Case LF_
AdvanceLine
Cp1 = BS_
Case Else
UngetChar ChrW$(Cp3)
UngetChar ChrW$(Cp2) End Select Else
UngetChar ChrW$(Cp2) End If
Case CR_
CheckLF = True
Cp1 = LF_ End Select
If CheckLF Then
Cp2 = NextCodePoint If Cp2 <> LF_ Then UngetChar ChrW$(Cp2) End If
If Cp1 = LF_ Then AdvanceLine
GetCodePoint = Cp1 End Function
Private Function NextCodePoint() As Integer Dim Result As Integer
Get #File_, , Result
RunningColumn_ = RunningColumn_ + 1
NextCodePoint = Result End Function
Private Function GetChar() As String Dim Cp As Integer
Cp = GetCodePoint
GetChar = ToChar(Cp) End Function
Private Function ToChar(ByVal CodePoint As Integer) As String Dim Bytes(0 To 1) As Byte
Bytes(0) = CodePoint And &HFF
Bytes(1) = ((CodePoint And &HFF00) \ &H100) And &HFF 'CodePoint >> 8
ToChar = Bytes End Function
Private Sub AdvanceLine()
RunningLine_ = RunningLine_ + 1
PreviousColumn_ = RunningColumn_
RunningColumn_ = 1 End Sub
Private Sub UngetChar(ByVal Character As String) Dim Pos As Long Dim Length As Long
Length = SizeOf(kwInteger) If Character = vbBack Then Length = Length * 2 + Len(vbNewLine) * SizeOf(kwInteger)
Pos = Seek(File_) Seek #File_, Pos - Length
Select Case Character Case vbLf, vbBack
RunningLine_ = RunningLine_ - 1
RunningColumn_ = PreviousColumn_ End Select
RunningColumn_ = RunningColumn_ - IIf(Character = vbBack, 2, 1) End Sub
Private Sub Fail(ByVal Msg As String)
Err.Raise vbObjectError + 13, "Scanner", FilePath_ & "(" & RunningLine_ & ", " & FrozenColumn_ & ") " & Msg End Sub
Private Function ReadIdentifier(ByVal CodePoint As Integer) Const MAX_LENGTH = 255
Dim IsOK As Boolean Dim Cp As Integer Dim Count As Integer Dim Index As Long Dim Name As String Dim Ch As String * 1 Dim Suffix As String * 1 Dim Buffer As String * MAX_LENGTH Dim Result As Token
IsOK = Ch = "_" If Not IsOK Then IsOK = Ch >= "0"And Ch <= "9" If Not IsOK Then IsOK = IsLetter(Cp) If Not IsOK Then IsOK = IsSurrogate(Cp) If Not IsOK Then Exit Do
Count = Count + 1 If Count > MAX_LENGTH Then Fail "Identifier too long"
Mid$(Buffer, Count, 1) = Ch Loop
Set Result = NewToken(tkIdentifier, Suffix:=Suffix)
Name = Left$(Buffer, Count)
Index = NameBank.Keywords.IndexOf(Name)
If Index <> 0 Then
Result.Kind = tkKeyword Else
Index = NameBank.Operators.IndexOf(Name)
If Index <> 0 Then
Result.Kind = tkOperator Else
Index = NameBank.Contextuals.IndexOf(Name)
If Index <> 0 Then
Index = Index + NameBank.Keywords.Count Else
Index = NameBank.Ids.IndexOf(Name)
If Index = 0 Then
NameBank.Ids.Add Name, Name
Index = NameBank.Ids.Count End If
Index = Index + NameBank.Keywords.Count + NameBank.Contextuals.Count End If End If End If
Select Case Result.Kind Case tkKeyword, tkOperator If Result.Suffix <> vbNullChar Then If Index = kwString And Result.Suffix = "$"Then
Result.Kind = tkIdentifier If Not NameBank.Ids.Exists("String") Then NameBank.Ids.Add "String", "String"
Index = NameBank.Ids.IndexOf("String") + NameBank.Keywords.Count + NameBank.Contextuals.Count Else
Fail "Keyword or operator cannot have type-declaration character" End If End If End Select
Result.Code = Index Set ReadIdentifier = Result End Function
Private Function ReadEscapedIdentifier() As Token Const MAX_LENGTH = 255
Dim Cp As Integer Dim Count As Integer Dim Name As String Dim Suffix As String * 1 Dim Buffer As String * MAX_LENGTH Dim Token As Token
Do Until AtEnd
Cp = GetCodePoint If Cp = AscW("]") Then Exit Do If Cp = LF_ Then Fail "Invalid identifier"
Count = Count + 1 If Count > MAX_LENGTH Then Fail "Identifier too long"
Mid$(Buffer, Count, 1) = ToChar(Cp) Loop
If Not AtEnd Then
Suffix = GetChar
Select Case Suffix Case"%", "&", "^", "@", "!", "#", "$" Rem OK
Case Else
UngetChar Suffix
Suffix = vbNullChar End Select End If
Set Token = NewToken(tkEscapedIdentifier, Suffix:=Suffix)
Name = Left$(Buffer, Count)
Token.Code = NameBank.Ids.IndexOf(Name)
If Token.Code = 0 Then
NameBank.Ids.Add Name, Name
Token.Code = NameBank.Ids.Count End If
Set ReadEscapedIdentifier = Token End Function
Private Function ReadString() As Token Const MAX_LENGTH = 1013
Dim Count As Integer Dim Ch As String * 1 Dim Buffer As String * MAX_LENGTH
Do If Count = MAX_LENGTH Then Fail "String too long"
If AtEnd Then
Ch = vbLf Else
Ch = GetChar End If
Select Case Ch Case"""" If AtEnd Then Exit Do
Ch = GetChar
If Ch = """"Then
Count = Append(Count, Buffer, Ch) Else Rem We read too much. Let's put it "back".
UngetChar Ch Exit Do End If
Case vbLf
Fail "Unclosed string"
Case Else
Count = Append(Count, Buffer, Ch) End Select Loop
Set ReadString = NewToken(tkString, , Left$(Buffer, Count)) End Function
Private Function Append(ByVal Count As Integer, ByRef Buffer As String, ByVal Ch As String) As Integer
Count = Count + 1
Mid$(Buffer, Count, 1) = Ch
Append = Count End Function
Private Function ReadInteger(Optional ByVal FirstDigit As String) As Token Const MAX_LENGTH = 29
Dim Cp As Integer Dim Count As Integer Dim Ch As String * 1 Dim Suffix As String * 1 Dim Buffer As String * MAX_LENGTH
If FirstDigit >= "0"And FirstDigit <= "9"Then
Count = 1
Mid$(Buffer, Count, 1) = FirstDigit End If
Do Until AtEnd If Count = MAX_LENGTH Then Fail "Literal too long"
Cp = GetCodePoint
Ch = ToChar(Cp)
Set ReadInteger = NewToken(tkIntegerNumber, , Left$(Buffer, Count), Suffix) End Function
Private Function ReadFloat(ByVal FirstDigit As String) As Token Dim Ch As String * 1 Dim Result As Token Dim FracPart As Token
Set Result = ReadInteger(FirstDigit:=FirstDigit)
If Result.Suffix = vbNullChar Then If Not AtEnd Then
Ch = GetChar
If Ch = "."Then Set FracPart = ReadInteger If FracPart.Text = ""Then Fail "Invalid literal"
Result.Text = Result.Text & "." & FracPart.Text
Result.Kind = tkFloatNumber
Result.Suffix = FracPart.Suffix Else
UngetChar Ch End If End If End If
Set ReadFloat = Result End Function
Private Function ReadNumber(ByVal FirstDigit As String) As Token Dim Ch As String * 1 Dim Sg As String * 1 Dim Result As Token Dim ExpPart As Token
Set Result = ReadFloat(FirstDigit)
If Result.Suffix = vbNullChar Then If Not AtEnd Then
Ch = GetChar
Select Case Ch Case"e", "E" If AtEnd Then
UngetChar Ch Else
Sg = GetChar
If Sg = "-"Or Sg = "+"Then
Ch = "" Else
Ch = Sg
Sg = "+" End If
Set ExpPart = ReadInteger(FirstDigit:=Ch) If ExpPart.Text = ""Or ExpPart.Suffix <> vbNullChar Then Fail "Invalid literal"
Result.Text = Result.Text & "E" & Sg & ExpPart.Text
Result.Kind = tkSciNumber End If
Case Else
UngetChar Ch End Select End If End If
Set ReadNumber = Result End Function
Private Function ReadAmpersand() As Token Dim Ch As String * 1 Dim Token As Token
Ch = GetChar
Select Case Ch Case"b", "B" Set Token = ReadBin
Case"o", "O" Set Token = ReadOctal
Case"h", "H" Set Token = ReadHexa
Case"=" Set Token = NewToken(tkOperator, opCompConcat)
Case Else
UngetChar Ch Set Token = NewToken(tkOperator, opConcat) End Select
Set ReadAmpersand = Token End Function
Private Function ReadBin() As Token Const MAX_LENGTH = 96
Dim Count As Integer Dim Ch As String * 1 Dim Suffix As String * 1 Dim Buffer As String * MAX_LENGTH
Do Until AtEnd If Count = MAX_LENGTH Then Fail "Literal too long"
Ch = GetChar
If Count = 0 Then Fail "Invalid literal" Set ReadHexa = NewToken(tkHexaNumber, , Left$(Buffer, Count), Suffix) End Function
Private Function ReadHash() As Token Dim Cp As Integer Dim Number As Integer Dim Name As String Dim Ch As String * 1 Dim Token As Token
Rem Let's get the first number. Set Token = ReadInteger
If Token.Text = ""Then Rem Maybe we have a month name?
Name = ReadMonthName
Select Case UCase$(Name) Case UCase$(vIf), UCase$(vElseIf), UCase$(vElse), UCase$(vEnd), UCase$(vConst) Rem Not a month name, we have a compiler directive instead. Set ReadHash = NewToken(tkDirective, Text:=Name) Exit Function
Case""
Fail Msg_
Case Else
Number = ConvertNameToNumber(Name)
If Number = 0 Then Rem Not a month name, we have a variable file-handle instead. Rem Hopefully this variable is not named Feb, for instance, otherwise we'll get tricked... Set ReadHash = NewToken(tkFileHandle, Text:=Name) Exit Function End If
Token.Text = CStr(Number) End Select End If
Rem Let's get the first separator.
Cp = GetCodePoint
Ch = ToChar(Cp)
If IsLetter(Cp) Or Ch = ","Then Rem We have a numeric file-handle
UngetChar Ch
Token.Kind = tkFileHandle Set ReadHash = Token Exit Function End If
If Ch = ":"Then Rem We are reading a time literal.
Name = ReadTime(Token.Text)
Rem Date literal must end with a '#'.
Ch = GetChar If Ch <> "#"Then Fail Msg_
Name = "1899-12-30 " & Name Set ReadHash = NewToken(tkDateTime, Text:=Name) Exit Function End If
Rem We'll suppose it is a valid separator. On Error Resume Next
Name = ReadDate(Token.Text, Ch)
If Err.Number Then Rem It is not a date, but a numeric file handle Rem TODO: Can ReadDate scan more than one character? On Error GoTo 0
UngetChar Ch
Token.Kind = tkFileHandle Set ReadHash = Token Exit Function End If
On Error GoTo 0
Ch = GetChar
Select Case Ch Case" " Rem We may have a date and time literal together. Set ReadHash = NewToken(tkDateTime, Text:=ReadTime) If ReadHash.Text = ""Then Fail Msg_
ReadHash.Text = Name & " " & ReadHash.Text
Ch = GetChar If Ch <> "#"Then Fail Msg_
Case"#" Rem Literal does not have a time part. Let's add it. Set ReadHash = NewToken(tkDateTime, Text:=Name & " 00:00:00")
Case Else
Fail Msg_ End Select End Function
Private Function ReadDate(ByVal FirstNumber As String, ByVal Separator As String) As String Dim YYYY As Integer Dim MM As Integer Dim DD As Integer Dim Result As String Dim Ch As String * 1 Dim SecondNumber As Token Dim ThirdNumber As Token
Set SecondNumber = ReadInteger If SecondNumber.Text = ""Then Fail Msg_
Rem The next separator must match the first one.
Ch = GetChar If Ch <> Separator Then Fail Msg_
Set ThirdNumber = ReadInteger If ThirdNumber.Text = ""Then Fail Msg_
If CInt(FirstNumber) >= 100 And Separator = "-"Then
YYYY = CInt(FirstNumber)
MM = CInt(SecondNumber.Text)
DD = CInt(ThirdNumber.Text) Else
MM = CInt(FirstNumber)
DD = CInt(SecondNumber.Text)
YYYY = CInt(ThirdNumber.Text)
If YYYY < 100 Then
YYYY = YYYY + 1900 If YYYY < 1950 Then YYYY = YYYY + 100 End If End If
Rem Validate year. If YYYY > 9999 Then Fail Msg_
Rem Validate month. If MM < 1 Or MM > 12 Then Fail Msg_
Rem Validate day. Select Case MM Case 4, 6, 9, 11 If DD > 30 Then Fail Msg_
Case 2 If YYYY Mod 4 = 0 And YYYY Mod 100 <> 0 Or YYYY Mod 400 = 0 Then If DD > 29 Then Fail Msg_ Else If DD > 28 Then Fail Msg_ End If
Case Else If DD > 31 Then Fail Msg_ End Select
Rem Put it together in YYYY-MM-DD format. If YYYY < 1000 Then Result = "0" If YYYY < 100 Then Result = Result & "0" If YYYY < 10 Then Result = Result & "0"
Result = Result & CStr(YYYY)
Result = Result & "-"
If MM < 10 Then Result = Result & "0"
Result = Result & CStr(MM)
Result = Result & "-"
If DD < 10 Then Result = Result & "0"
Result = Result & CStr(DD)
ReadDate = Result End Function
Private Function ReadTime(Optional ByVal FirstNumber As String) As String Dim HH As Integer Dim NN As Integer Dim SS As Integer Dim Number As String Dim Ch As String * 1 Dim Ch2 As String * 1 Dim AP As String * 1
On Error GoTo GoneWrong
HH = CInt(FirstNumber)
Number = ReadInteger If Number = ""Then Err.Raise 0
NN = CInt(Number)
Ch = GetChar
If Ch = ":"Then
Number = ReadInteger If Number = ""Then Err.Raise 0
SS = CInt(Number) Else
UngetChar Ch End If
If Not AtEnd Then
Ch = GetChar
If Ch = " "Then If Not AtEnd Then
Ch = GetChar
If Ch = "a"Or Ch = "A"Then
Ch2 = GetChar
If Ch2 = "m"Or Ch2 = "M"Then
AP = "A" Else
UngetChar Ch2
UngetChar Ch
UngetChar " " End If
ElseIf Ch = "p"Or Ch = "P"Then
Ch2 = GetChar
If Ch2 = "m"Or Ch2 = "M"Then
AP = "P" Else
UngetChar Ch2
UngetChar Ch
UngetChar " " End If
Else
UngetChar Ch
UngetChar " " End If End If Else
UngetChar Ch End If End If
Rem Validate hour, minute, and second. If HH < 0 Or HH > 23 Then Err.Raise 0 If NN < 0 Or NN > 59 Then Err.Raise 0 If SS < 0 Or SS > 59 Then Err.Raise 0
If AP = "A"Then If HH = 12 Then HH = 0
ElseIf AP = "P"Then If HH <> 12 Then HH = HH + 12 End If
Rem Put it together in HH:NN:SS format.
Number = CStr(SS) If SS < 10 Then Number = "0" & Number
Number = ":" & Number
Number = CStr(NN) & Number If NN < 10 Then Number = "0" & Number
Number = ":" & Number
Number = CStr(HH) & Number If HH < 10 Then Number = "0" & Number
ReadTime = Number Exit Function
GoneWrong:
Fail Msg_ End Function
Private Function ReadMonthName() As String Dim Result As String Dim Ch As String * 1 Dim Prv As String * 1
Do Until AtEnd
Prv = Ch
Ch = GetChar
Select Case Ch Case"#", vbLf, ",", ";", ")", " "
UngetChar Ch Exit Do
Case"0"To"9" Rem We safely can assume we read two characters more than needed.
UngetChar Ch
UngetChar Prv
Result = Left$(Result, Len(Result) - 1) Exit Do
Case Else
Result = Result & Ch End Select Loop
ReadMonthName = Result End Function
Private Function ConvertNameToNumber(ByVal Name As String) As Integer Dim Count As Integer Dim Result As Integer Dim MonthName As Variant Static MonthNames As Variant
If IsEmpty(MonthNames) Then
MonthNames = Array("January", "February", "March", "April", "May", "June", _ "July", "August", "September", "October", "November", "December") End If
For Each MonthName In MonthNames
Count = Count + 1
If StrComp(Name, MonthName, vbTextCompare) = 0 Then Result = Count If Result = 0 Then: If StrComp(Name, Left$(MonthName, 3), vbTextCompare) = 0 Then Result = Count If Result <> 0 Then Exit For Next
ConvertNameToNumber = Result End Function
Private Function NewToken( _ ByVal Kind As TokenKind, _ Optional Code As Long, _ Optional ByVal Text As String, _ Optional ByVal Suffix As String = vbNullChar _
) As Token Set NewToken = New Token
With NewToken
.Text = Text
.Code = Code
.Kind = Kind
.Suffix = Suffix
.Line = RunningLine_
.Column = FrozenColumn_ End With End Function
Private Function ReadComment(Optional ByVal IsRem As Boolean) As Token Const MAX_LENGTH = 1013
Dim Count As Integer Dim Text As String Dim Ch As String * 1 Dim Buffer As String * MAX_LENGTH
If IsRem Then
Text = vRem & " " Else
Text = " '" End If
Count = Len(Text)
Mid$(Buffer, 1, Count) = Text
Do Until AtEnd If Count = MAX_LENGTH Then Fail "Comment too long"
Ch = GetChar If Ch = vbLf Then Exit Do
Set ReadComment = NewToken(tkComment, Text:=Left$(Buffer, Count)) End Function
Private Sub DiscardComment() Dim Count As Long Dim Ch As String * 1
Count = 1
Do Until AtEnd
Ch = GetChar
Select Case Ch Case"`"
Count = Count + 1
Case"´"
Count = Count - 1 If Count = 0 Then Exit Do End Select Loop End Sub
Private Sub Class_Terminate() If File_ <> 0 Then Close #File_ End Sub End Class
Public Class SeekConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snSeek End Property End Class
Public Class SelectConstruct Option Explicit Implements IStmt
Private Cases_ As KeyedList Private CaseElse_ As KeyedList
Public Value As IExpression
Private Sub Class_Initialize() Set Cases_ = New KeyedList Set Cases_.T = NewValidator(TypeName(New CaseConstruct))
Set CaseElse_ = New KeyedList Set CaseElse_.T = New StmtValidator End Sub
Public Property Get Cases() As KeyedList Set Cases = Cases_ End Property
Public Property Get CaseElse() As KeyedList Set CaseElse = CaseElse_ End Property
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snSelect End Property End Class
Public Class SetConstruct Option Explicit Implements IStmt
Public Name As IExpression Public Value As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snSet End Property End Class
Public Class SourceFile Option Explicit
Private Entities_ As KeyedList
Public Path As String
Private Sub Class_Initialize() Set Entities_ = New KeyedList Set Entities_.T = NewValidator(TypeName(New Entity))
Entities_.CompareMode = vbTextCompare End Sub
Public Static Property Get Entities() As KeyedList Set Entities = Entities_ End Property End Class
Public Class StmtValidator Option Explicit Implements IKLValidator
Private Function IKLValidator_Validate(ByVal Item As Variant) As Boolean
IKLValidator_Validate = TypeOf Item Is IStmt End Function End Class
Public Class StopConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snStop End Property End Class
Public Class SubConstruct Option Explicit
Private Parms_ As KeyedList Private Body_ As KeyedList
Public Access As Accessibility Public IsStatic As Boolean Public IsDefault As Boolean Public Id As Identifier
Private Sub Class_Initialize() Set Parms_ = New KeyedList Set Parms_.T = NewValidator(TypeName(New Parameter))
Parms_.CompareMode = vbTextCompare
Set Body_ = New KeyedList Set Body_.T = New StmtValidator End Sub
Public Property Get Parameters() As KeyedList Set Parameters = Parms_ End Property
Public Static Property Get Body() As KeyedList Set Body = Body_ End Property End Class
Public Class SubscriptPair Option Explicit
Private UpperBound_ As IExpression
Public LowerBound As IExpression
Public Property Get UpperBound() As IExpression Set UpperBound = UpperBound_ End Property
Public Property Set UpperBound(ByVal Value As IExpression) If Not UpperBound_ Is Nothing Then Set LowerBound = UpperBound_ Set UpperBound_ = Value End Property End Class
Public Class Symbol Option Explicit Implements IExpression
Public Value As Token
Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekSymbol End Property End Class
Public Code As Long Public Line As Long Public Column As Long Public Spaces As Long Public Text As String Public Suffix As String Public Kind As TokenKind
Private Sub Class_Initialize()
Text = " "
Suffix = vbNullChar End Sub
Public Function IsKeyword(ByVal Code As Long) As Boolean If Kind <> tkKeyword Then Exit Function If Me.Code <> Code Then Exit Function
IsKeyword = True End Function
Public Function IsOperator(ByVal Code As Long) As Boolean If Kind <> tkOperator Then Exit Function If Me.Code <> Code Then Exit Function
IsOperator = True End Function End Class
Public Class TupleConstruct Option Explicit Implements IExpression
Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekTuple End Property
Public Static Property Get Elements() As KeyedList Dim Hidden As New KeyedList
Set Elements = Hidden End Property End Class
Public Class TypeConstruct Option Explicit
Private Members_ As KeyedList
Public Access As Accessibility Public Id As Identifier
Private Sub Class_Initialize() Set Members_ = New KeyedList Set Members_.T = NewValidator(TypeName(New Variable))
Members_.CompareMode = vbTextCompare End Sub
Public Property Get Members() As KeyedList Set Members = Members_ End Property End Class
Public Class UnaryExpression Option Explicit Implements IExpression
Public Operator As Operator Public Value As IExpression
Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekUnaryExpr End Property End Class
Public Class UnlockConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snUnlock End Property End Class
Public Class Variable Option Explicit Implements IStmt
Private Subscripts_ As KeyedList
Public IsStatic As Boolean Public HasWithEvents As Boolean Public HasNew As Boolean Public DataType As DataType Public Init As IExpression Public Access As Accessibility
Private Sub Class_Initialize() Set Subscripts_ = New KeyedList Set Subscripts_.T = NewValidator(TypeName(New SubscriptPair)) End Sub
Public Static Property Get Id() As Identifier Dim Hidden As New Identifier Set Id = Hidden End Property
Public Static Property Get Subscripts() As KeyedList Set Subscripts = Subscripts_ End Property
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snDim End Property End Class
Public Class VariantEnumerator Option Explicit
Private Declare Function HeapAlloc Lib"kernel32" ( _ ByVal hHeap As LongPtr, _ ByVal dwFlags As Long, _ ByVal dwBytes As Long _
) As LongPtr
Public Event NextItem(ByVal Qty As Long, ByRef Items As Variant, ByRef Returned As Long, ByRef Data As Variant) Public Event Skip(ByVal Qty As Long, ByRef Data As Variant) Public Event Reset(ByRef Data As Variant) Public Event Clone(ByRef Obj As Variant, ByRef Data As Variant)
Public Function NewEnum(ByVal ParentObj As Object) As IUnknown Dim Ptr As LongPtr Dim Obj As IEnumVariantType
Rem Copy structure to the allocated memory
CopyMemory Destination:=ByVal Ptr, Source:=VarPtr(Obj), Length:=Len(Obj) Rem Return pointer as an IUnknown.
CopyMemory NewEnum, Source:=VarPtr(Ptr), Length:=Len(Ptr) End Function
Friend Sub OnNextItem(ByVal Qty As Long, ByRef Items As Variant, ByRef Returned As Long, ByRef Data As Variant) RaiseEvent NextItem(Qty, Items, Returned, Data) End Sub
Friend Sub OnSkip(ByVal Qty As Long, ByRef Data As Variant) RaiseEvent Skip(Qty, Data) End Sub
Friend Sub OnReset(ByRef Data As Variant) RaiseEvent Reset(Data) End Sub
Friend Sub OnClone(ByRef Obj As Variant, ByRef Data As Variant) RaiseEvent Clone(Obj, Data) End Sub
Private Function GetProc(ByRef Proc As LongPtr) As LongPtr
GetProc = Proc End Function
Private Sub IncRefCount(ByRef Obj As Object) Dim Dummy As Object Dim Nil As LongPtr
Set Dummy = Obj
CopyMemory Destination:=Dummy, Source:=VarPtr(Nil), Length:=Len(Nil) End Sub End Class
Public Class WhileConstruct Option Explicit Implements IStmt
Private Body_ As KeyedList
Public Condition As IExpression
Private Sub Class_Initialize() Set Body_ = New KeyedList Set Body_.T = New StmtValidator End Sub
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snWhile End Property
Public Property Get Body() As KeyedList Set Body = Body_ End Property End Class
Public Class WidthConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snWidth End Property End Class
Public Class WithConstruct Option Explicit Implements IStmt
Private Body_ As KeyedList
Public PinObject As IExpression
Private Sub Class_Initialize() Set Body_ = New KeyedList Set Body_.T = New StmtValidator End Sub
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snWith End Property
Public Property Get Body() As KeyedList Set Body = Body_ End Property End Class
Public Class WriteConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snWrite End Property End Class
Public Module ForwardCompatibility Option Explicit
Public Const vbLongLong = 20 Public Const vbLongPtr = 37
Public Enum [LongPtr]
Zero End Enum End Module
Private Module Globals Public NameBank As New NameBank
Public Function NewId(ByVal Token As Token) As Identifier Dim Result As Identifier
Set Result = New Identifier Set Result.Name = Token Set NewId = Result End Function
Public Function NewDataType(ByVal Token As Token) As DataType Dim Result As DataType
Set Result = New DataType Set Result.Id = NewId(Token) Set NewDataType = Result End Function
Public Function NewOperator(ByVal Token As Token) As Operator Dim Result As Operator
Set Result = New Operator Set Result.Value = Token Set NewOperator = Result End Function
Public Function NewValidator(ByVal AllowedType As String) As DefaultValidator Dim Result As DefaultValidator
Set Result = New DefaultValidator
Result.AllowedType = AllowedType Set NewValidator = Result End Function
Public Function SizeOf(ByVal VariableType As Long) As Integer Select Case VariableType Case kwBoolean, kwInteger
SizeOf = 2
Case kwByte
SizeOf = 1
Case kwLong, kwSingle
SizeOf = 4
Case kwLongLong, kwCurrency, kwDouble, kwDate
SizeOf = 8
Case cxDecimal
SizeOf = 16
Case cxObject 'Pointer
#If Win32 Then
SizeOf = 4
#Else
SizeOf = 8
#End If
Case kwVariant
#If Win32 Then
SizeOf = 16
#Else
SizeOf = 24
#End If
Case Else Debug.Assert False End Select End Function
Public Function ComparePrecedence(ByVal LeftOp As Operator, ByVal RightOp As Operator) As Integer Dim LHS As Integer Dim RHS As Integer
Case Else Debug.Assert False End Select End Function End Module
Private Module Messages Option Explicit
Public Property Get Msg001() As String
Msg001 = "Public, Private, Class, or Module" End Property
Public Property Get Msg002() As String
Msg002 = "Class or Module" End Property
Public Property Get Msg003() As String
Msg003 = "identifier" End Property
Public Property Get Msg004() As String
Msg004 = "Rule: End (Class | Module)" End Property
Public Property Get Msg005() As String
Msg005 = "Rule: vbCr | vbLf | vbCrLf | : | '" End Property
Public Property Get Msg006() As String
Msg006 = "Ambiguous name detected: " End Property
Public Property Get Msg007() As String
Msg007 = "Rule: [Public | Private] (Class | Module) identifier" End Property
Public Property Get Msg008() As String
Msg008 = "Rule: [Public | Private] identifier" End Property
Public Property Get Msg009() As String
Msg009 = "Rule: (Public | Private) identifier" End Property
Public Property Get Msg010() As String
Msg010 = "Duplicate Option statement" End Property
Public Property Get Msg011() As String
Msg011 = "Rule: Option Base (0 | 1)" End Property
Public Property Get Msg012() As String
Msg012 = "Rule: [Public] Event identifier [([parms])]" End Property
Public Property Get Msg013() As String
Msg013 = "Rule: Option Compare (Binary | Text)" End Property
Public Property Get Msg014() As String
Msg014 = "Binary or Text" End Property
Public Property Get Msg015() As String
Msg015 = "Rule: Option (Base | Compare | Explicit)" End Property
Public Property Get Msg016() As String
Msg016 = "Only valid inside Class" End Property
Public Property Get Msg017() As String
Msg017 = "Event can only be Public" End Property
Public Property Get Msg018() As String
Msg018 = "Expected: Option or Deftype or Public or Private or Const or Enum or Declare or Type" End Property
Public Property Get Msg019() As String
Msg019 = "Rule: Deftype first[-last] [, ...]" End Property
Public Property Get Msg020() As String
Msg020 = "first" End Property
Public Property Get Msg021() As String
Msg021 = "last" End Property
Public Property Get Msg022() As String
Msg022 = "Duplicate Deftype statement" End Property
Public Property Get Msg023() As String
Msg023 = "Rule: [Public | Private] Const identifier [As data_type] = expression [, ...]" End Property
Public Property Get Msg024() As String
Msg024 = "Identifier already has a type-declaration character" End Property
Public Property Get Msg025() As String
Msg025 = "data type" End Property
Public Property Get Msg026() As String
Msg026 = "Fixed-length allowed only for String" End Property
Public Property Get Msg027() As String
Msg027 = "list separator or end of statement" End Property
Public Property Get Msg028() As String
Msg028 = "Rule: [Public | Private] Enum identifier" End Property
Public Property Get Msg029() As String
Msg029 = "Enum cannot have a type-declaration character" End Property
Public Property Get Msg030() As String
Msg030 = "Rule: [Public | Private] Enum identifier" End Property
Public Property Get Msg031() As String
Msg031 = "End of statement" End Property
Public Property Get Msg032() As String
Msg032 = "Rule: identifier [= expression]" End Property
Public Property Get Msg033() As String
Msg033 = "Enum member cannot have a type-declaration character" End Property
Public Property Get Msg034() As String
Msg034 = "Rule: End Enum" End Property
Public Property Get Msg035() As String
Msg035 = "Enum without members is not allowed" End Property
Public Property Get Msg036() As String
Msg036 = "Rule: [Public | Private] Declare (Sub | Function) identifier [CDecl] " & _ "Lib lib_string [Alias alias_string] ([parms]) [As data_type[()]]" End Property
Public Property Get Msg037() As String
Msg037 = "Sub or Function" End Property
Public Property Get Msg038() As String
Msg038 = "lib string" End Property
Public Property Get Msg039() As String
Msg039 = "alias string" End Property
Public Property Get Msg040() As String
Msg040 = "Duplicated declaration in current scope" End Property
Public Property Get Msg041() As String
Msg041 = "Rule: [[Optional] (ByVal | ByRef) | ParamArray] identifier[type_declaration_char][()] " & _ "[As data_type] [:= expression]" End Property
Public Property Get Msg042() As String
Msg042 = "Too many formal parameters" End Property
Public Property Get Msg043() As String
Msg043 = "Cannot have both Optional and ParamArray parameters" End Property
Public Property Get Msg044() As String
Msg044 = "Optional not allowed" End Property
Public Property Get Msg045() As String
Msg045 = "ParamArray not allowed" End Property
Public Property Get Msg046() As String
Msg046 = "ByVal not allowed" End Property
Public Property Get Msg047() As String
Msg047 = "ByRef not allowed" End Property
Public Property Get Msg048() As String
Msg048 = "ParamArray parameter must be an array" End Property
Public Property Get Msg049() As String
Msg049 = "Identifier already has a type-declaration character" End Property
Public Property Get Msg050() As String
Msg050 = "As [project_name.]identifier" End Property
Public Property Get Msg051() As String
Msg051 = "ParamArray must be an array of Variants" End Property
Public Property Get Msg052() As String
Msg052 = "Sub, Property Let, or Property Get cannot have an As clause" End Property
Public Property Get Msg053() As String
Msg053 = "Parameter is not Optional" End Property
Public Property Get Msg054() As String
Msg054 = "ParamArray cannot have a default value" End Property
Public Property Get Msg055() As String
Msg055 = "Property Let/Set should have at least one parameter" End Property
Public Property Get Msg056() As String
Msg056 = "Property Let/Set should have at least one non-optional parameter" End Property
Public Property Get Msg057() As String
Msg057 = "Unclosed parenthesis" End Property
Public Property Get Msg058() As String
Msg058 = "Rule: Implements [project_name.]identifier" End Property
Public Property Get Msg059() As String
Msg059 = "Project name or identifier" End Property
Public Property Get Msg060() As String
Msg060 = "Type-declaration character not allowed here" End Property
Public Property Get Msg061() As String
Msg061 = "(Public | Private | Static | Dim) [WithEvents] identifier[type_declaration_character]" & _ "[([[n To] m[, ...]])] [As (data_type [= expression] | New class_name)] [, ...]" End Property
Public Property Get Msg062() As String
Msg062 = "Invalid use of New" End Property
Public Property Get Msg063() As String
Msg063 = "Invalid inside Sub, Function, or Property" End Property
Public Property Get Msg064() As String
Msg064 = "Invalid use of New with array" End Property
Public Property Get Msg065() As String
Msg065 = "Invalid expression" End Property
Public Property Get Msg066() As String
Msg066 = "Rule: [Public | Private] Enum identifier" End Property
Public Property Get Msg067() As String
Msg067 = "Rule: member_name As data_type" End Property
Public Property Get Msg068() As String
Msg068 = "Rule: End Type" End Property
Public Property Get Msg069() As String
Msg069 = "Rule: [Public | Private | Friend] [Static] [Default] Sub identifier[([parms])]" End Property
Public Property Get Msg070() As String
Msg070 = "Rule: [Public | Private | Friend] [Static] [Default] Function identifier[type_declaration_character]" & _ "[()][([parms])] [As data_type[()]]" End Property
Public Property Get Msg071() As String
Msg071 = "Rule: [Public | Private | Friend] [Static] [Default] Property (Get | Let | Set) " & _ "identifier[type_declaration_character][()][([parms])] [As data_type[()]]" End Property
Public Property Get Msg072() As String
Msg072 = "Rule: End Sub" End Property
Public Property Get Msg073() As String
Msg073 = "Rule: End Function" End Property
Public Property Get Msg074() As String
Msg074 = "Rule: End Property" End Property
Public Property Get Msg075() As String
Msg075 = "Duplicate declaration in current scope" End Property
Public Property Get Msg076() As String
Msg076 = "Get or Let or Set" End Property
Public Property Get Msg077() As String
Msg077 = "Definitions of property procedures for the same property are inconsistent, " & _ "or property procedure has an optional parameter, a ParamArray, or an invalid Set final parameter" End Property
Public Property Get Msg078() As String
Msg078 = "Argument required for Property Let or Property Set" End Property
Public Property Get Msg079() As String
Msg079 = "Rule: (Public | Private | Friend) identifier" End Property
Public Property Get Msg080() As String
Msg080 = "Duplicate Static statement" End Property
Public Property Get Msg081() As String
Msg081 = "Duplicate Iterator statement" End Property
Public Property Get Msg082() As String
Msg082 = "Duplicate Default statement" End Property
Public Property Get Msg083() As String
Msg083 = "A Function cannot be both Default and Iterator" End Property
Public Property Get Msg084() As String
Msg084 = "Expected: = or argument" End Property
Public Property Get Msg085() As String
Msg085 = "Expected: End " End Property
Public Property Get Msg086() As String
Msg086 = "Expected: Get or Let or Set" End Property
Public Property Get Msg087() As String
Msg087 = "Expected: statement" End Property
Public Property Get Msg088() As String
Msg088 = "Rule: If condition Then" End Property
Public Property Get Msg089() As String
Msg089 = "Expected: Else or ElseIf or End If" End Property
Public Property Get Msg090() As String
Msg090 = "Block If without End If" End Property
Public Property Get Msg091() As String
Msg091 = "Rule: Select Case expression" End Property
Public Property Get Msg092() As String
Msg092 = "Expected: > or >= or = or < or <= or <>" End Property
Public Property Get Msg093() As String
Msg093 = "Expected: Is or Else" End Property
Public Property Get Msg094() As String
Msg094 = "Expected: = or argument" End Property
Public Property Get Msg095() As String
Msg095 = "Rule: With object" End Property
Public Property Get Msg096() As String
Msg096 = "object" End Property
Public Property Get Msg097() As String
Msg097 = "Expected: Loop" End Property
Public Property Get Msg098() As String
Msg098 = "Rule: For identifier = start To end [Step increment]" End Property
Public Property Get Msg099() As String
Msg099 = "increment" End Property
Public Property Get Msg100() As String
Msg100 = "Rule: For Each variable In group" End Property
Public Property Get Msg101() As String
Msg101 = "variable" End Property
Public Property Get Msg102() As String
Msg102 = "group" End Property
Public Property Get Msg103() As String
Msg103 = "Expected: Next" End Property
Public Property Get Msg104() As String
Msg104 = "Expected: Wend or End While" End Property End Module
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
Public Sub PrettyPrint() Dim Nbsp As Boolean Dim HtmlFile As Integer Dim Index As Integer Dim Text As String Dim FilePath As String Dim Token As Token Dim Parser As Parser Dim Source As SourceFile
Rem Ensuring we close the file in case we have an error. On Error GoTo CloseIt
Rem File path for the source code is passed as a command-line argument. Set Source = New SourceFile
FilePath = Command$
Source.Path = FilePath
Set Parser = New Parser Set Parser.SourceFile = Source
Rem Output file will have the same name as the input file, but with an .HTML extension.
Index = InStrRev(FilePath, ".") If Index <> 0 Then FilePath = Left$(FilePath, Index - 1)
FilePath = FilePath & ".html"
HtmlFile = FreeFile Open FilePath For Output Access Write As #HtmlFile
Nbsp = True
Do Set Token = Parser.NextToken(ForPrint:=True)
If Nbsp Then For Index = 1 To Token.Spaces Print #HtmlFile, " "; Next Else Print #HtmlFile, Space$(Token.Spaces); End If
Select Case Token.Kind Case tkComment Print #HtmlFile, SPAN_COMMENT; EncodeHtml(Token.Text); "</span><br>"
Nbsp = True
Case tkIdentifier Print #HtmlFile, NameBank(Token);
Nbsp = False
Case tkIntegerNumber, tkFloatNumber, tkSciNumber Print #HtmlFile, Token.Text;
Nbsp = False
Case tkEscapedIdentifier Print #HtmlFile, "["; Token.Text; "]";
Nbsp = False
Case tkKeyword Print #HtmlFile, SPAN_KEYWORD; NameBank(Token); "</span>";
Nbsp = False
Case tkOctalNumber Print #HtmlFile, "&O"; Token.Text;
Case tkHexaNumber Print #HtmlFile, "&H"; UCase$(Token.Text);
Case tkFileHandle Print #HtmlFile, "#"; Token.Text;
Case tkString
Text = Token.Text
Text = Replace(Token.Text, """", """""")
Text = EncodeHtml(Text) Print #HtmlFile, SPAN_STRING; """"; Text; """</span>";
Case tkDateTime Print #HtmlFile, "#"; Token.Text; "#";
Case tkOperator If IsLetter(AscW(NameBank(Token))) Then Print #HtmlFile, SPAN_KEYWORD; NameBank(Token); "</span>";
Else Print #HtmlFile, EncodeHtml(NameBank(Token)); End If
Case tkLeftParenthesis Print #HtmlFile, "(";
Nbsp = False
Case tkRightParenthesis Print #HtmlFile, ")";
Nbsp = False
Case tkListSeparator Print #HtmlFile, ",";
Nbsp = False
Case tkSoftLineBreak Print #HtmlFile, ":";
Nbsp = False
Case tkPrintSeparator Print #HtmlFile, ";";
Nbsp = False
Case tkLineContinuation Print #HtmlFile, " _<br>"
Nbsp = True
Case tkHardLineBreak Print #HtmlFile, "<br />"
Nbsp = True
Case tkDirective Print #HtmlFile, "#"; Token.Text;
Nbsp = False
Case tkEndOfStream Exit Do End Select
If Token.Suffix <> vbNullChar Then Print #HtmlFile, Token.Suffix; Loop
CloseIt: Close #HtmlFile Rem This is equivalent to a Throw in a Catch. If Err.Number Then Err.Raise Err.Number End Sub
Private Function EncodeHtml(ByVal Text As String) As String
Text = Replace(Text, "&", "&")
Text = Replace(Text, "<", "<")
Text = Replace(Text, ">", ">")
EncodeHtml = Text End Function End Module
Public Module StringCentral Option Explicit
Private Const NO_OF_COLS = 5
Private Declare Function CopyMemory Lib"kernel32"Alias"RtlMoveMemory" _
(ByVal Dest As LongPtr, ByVal Src As LongPtr, ByVal Length As Long) As Long
Private CodePoints_() As Integer Private IsInit_ As Boolean
Private Sub Init() Dim Bytes() As Byte Dim Size As Long
IsInit_ = True
Bytes = LoadResData(101, "CUSTOM")
Size = UBound(Bytes) + 1 ReDim CodePoints_(0 To Size \ SizeOf(kwInteger) - 1) As Integer
CopyMemory VarPtr(CodePoints_(0)), VarPtr(Bytes(0)), Size End Sub
Public Function ToUpper(ByVal Text As String) As String Dim Cp As Integer Dim Pos As Long Dim Index As Long Dim Ch As String * 1 Dim Result As String
Result = Text
For Pos = 1 To Len(Text)
Ch = Mid$(Result, Pos, 1)
Select Case Ch Case"A"To"Z" Rem Nothing to do
Case"a"To"z"
Cp = AscW(Ch)
Ch = ChrW$(Cp - 32)
Case Else If Not IsInit_ Then Init
Cp = AscW(Ch)
Index = BinarySearch(CodePoints_, Cp, FirstIndex:=0, Step:=NO_OF_COLS) If Index <> -1 Then Ch = ChrW$(CodePoints_(Index + 1)) End Select
Mid$(Result, Pos, 1) = Ch Next
ToUpper = Result End Function
Public Function ToLower(ByVal Text As String) As String Dim Cp As Integer Dim Pos As Long Dim Index As Long Dim Ch As String * 1 Dim Result As String
Result = Text
For Pos = 1 To Len(Text)
Ch = Mid$(Result, Pos, 1)
Case Else If Not IsInit_ Then Init
Cp = AscW(Ch)
Index = BinarySearch(CodePoints_, Cp, FirstIndex:=3, Step:=NO_OF_COLS)
If Index <> 2 Then
Index = CodePoints_(Index + 1) If Index <> -1 Then Ch = ChrW$(CodePoints_(Index * NO_OF_COLS)) End If End Select
Mid$(Result, Pos, 1) = Ch Next
ToLower = Result End Function
Public Function ToTitle(ByVal Text As String) As String Dim ToUp As Boolean Dim Cp As Integer Dim Pos As Long Dim Index As Long Dim Ch As String * 1 Dim Result As String
Result = Text
ToUp = True
For Pos = 1 To Len(Text)
Ch = Mid$(Result, Pos, 1)
Cp = AscW(Ch)
If IsLetter(Cp) Then If ToUp Then
ToUp = False
Select Case Ch Case"A"To"Z" Rem Nothing to do
Case"a"To"z"
Ch = ChrW$(Cp - 32)
Case Else If Not IsInit_ Then Init Rem Search for a lower case character.
Index = BinarySearch(CodePoints_, Cp, FirstIndex:=0, Step:=NO_OF_COLS)
If Index = -1 Then Rem Search for an upper case character.
Index = BinarySearch(CodePoints_, Cp, FirstIndex:=3, Step:=NO_OF_COLS)
If Index <> 2 Then
Index = CodePoints_(Index + 1) * NO_OF_COLS
Ch = ChrW$(CodePoints_(Index + 2)) End If Else
Ch = ChrW$(CodePoints_(Index + 2)) End If End Select Else
Ch = ToLower(Ch) End If Else
ToUp = True End If
Mid$(Result, Pos, 1) = Ch Next
ToTitle = Result End Function
Private Function BinarySearch( _ ByRef SourceArray As Variant, _ ByVal Target As Variant, _ Optional ByVal FirstIndex As Integer, _ Optional ByVal Step As Integer = 1 _
) As Long Dim LeftPoint As Long Dim RightPoint As Long Dim MiddlePoint As Long Dim ResultIndex As Long
Select Case SourceArray(MiddlePoint) Case Is < Target
LeftPoint = MiddlePoint + Step
Case Is > Target
RightPoint = MiddlePoint - Step
Case Else
ResultIndex = MiddlePoint Exit Do End Select Loop
BinarySearch = ResultIndex End Function
Rem The first (high) surrogate is a 16-bit code value in the range U+D800 to U+DBFF. Private Function IsHighSurrogate(ByVal Character As Integer) As Boolean
IsHighSurrogate = Character >= -10240 And Character <= -9217 Or Character >= 55296 And Character <= 56319 End Function
Rem The second (low) surrogate is a 16-bit code value in the range U+DC00 to U+DFFF. Private Function IsLowSurrogate(ByVal Character As Integer) As Boolean
IsLowSurrogate = Character >= -9216 And Character <= -8193 Or Character >= 56320 And Character <= 57343 End Function
Public Function IsSurrogate(ByVal Character As Integer) As Boolean
IsSurrogate = IsLowSurrogate(Character) Or IsHighSurrogate(Character) End Function
Public Function IsLetter(ByVal CodePoint As Integer) As Boolean Select Case CodePoint Case -32768 To -24645, -24576 To -23412, -22761 To -22758, -22528 To -22527, -22525 To -22523, _
-22521 To -22518, -22516 To -22494, -22464 To -22413, -21504 To -10333, -1792 To -1491, _
-1488 To -1430, -1424 To -1319, -1280 To -1274, -1261 To -1257, -1251, -1249 To -1240, _
-1238 To -1226, -1224 To -1220, -1218, -1216, -1215, -1213, -1212, -1210 To -1103, _
-1069, -1068 To -707, -688 To -625, -622 To -569, -528 To -517, -400 To -396, -394 To -260, _
-223 To -198, -191 To -166, -154 To -66, -62 To -57, -54 To -49, -46 To -41, -38 To -36, _
65 To 90, 97 To 122, 170, 181, 186, 192 To 214, 216 To 246, 248 To 705, 710 To 721, _
736 To 740, 750, 890 To 893, 902, 904 To 906, 908, 910 To 929, 931 To 974, 976 To 1013, _
1015 To 1153, 1162 To 1299, 1329 To 1366, 1369, 1377 To 1415, 1488 To 1514, 1520 To 1522, _
1569 To 1594, 1600 To 1610, 1646, 1647, 1649 To 1747, 1749, 1765, 1766, 1774, 1775, _
1786 To 1788, 1791, 1808, 1810 To 1839, 1869 To 1901, 1920 To 1957, 1969, 1994 To 2026, 2036, _
2037, 2042
IsLetter = True End Select End Function
Select Case CodePoint Case NULL_CHAR, WHITE_SPACE, VERTICAL_TAB, EOM, NO_BREAK_SPACE, OGHAM_SPACE_MARK, MONGOLIAN_VOWEL_SEPARATOR, _
NARROW_NO_BREAK_SPACE, MEDIUM_MATHEMATICAL_SPACE, IDEOGRAPHIC_SPACE, EN_QUAD To HAIR_SPACE
IsSpace = True End Select End Function End Module
Private Declare Function HeapFree Lib"kernel32" ( _ ByVal hHeap As LongPtr, _ ByVal dwFlags As Long, _ ByRef lpMem As LongPtr _
) As Long
Public Declare Function GetProcessHeap Lib"kernel32" () As LongPtr
Public Declare Sub CopyMemory Lib"kernel32"Alias"RtlMoveMemory" ( _ ByRef Destination As Any, _ ByVal Source As LongPtr, _ ByVal Length As Long _
)
Public Type IEnumVariantType
VTable As LongPtr ''''''Address of the "virtual table" below.
QueryInterface As LongPtr ''''''Interface IUnknown.
AddRef As LongPtr ''''''Interface IUnknown.
Release As LongPtr ''''''Interface IUnknown.
NextItem As LongPtr ''''''Interface IEnumVARIANT.
Skip As LongPtr ''''''Interface IEnumVARIANT.
Reset As LongPtr ''''''Interface IEnumVARIANT.
Clone As LongPtr ''''''Interface IEnumVARIANT.
Count As Long ''''''Reference counter.
Ptr As LongPtr ''''''Pointer to this structure's allocated memory.
Ref As LongPtr ''''''Reference to VariantEnumerator.
Data As Variant ''''''Container to user's data.
Parent As LongPtr ''''''Reference to object being iterated. End Type
Public Function QueryInterfaceEntry(ByRef This As IEnumVariantType, ByVal iid As Long, ByRef ppvObject As Long) As Long Rem Increment reference count.
This.Count = This.Count + 1
Rem Return pointer to IEnumVariantType structure.
ppvObject = VarPtr(This) End Function
Public Function AddRefEntry(ByRef This As IEnumVariantType) As Long Rem Increment reference count.
This.Count = This.Count + 1
Rem Return it.
AddRefEntry = This.Count End Function
Public Function ReleaseEntry(ByRef This As IEnumVariantType) As Long Rem Decrement reference count.
This.Count = This.Count - 1
Rem Return it.
ReleaseEntry = This.Count
Rem If there's no more references, deallocates IEnumVariantType's memory. If This.Count = 0 Then
DecRefCount This.Parent
HeapFree GetProcessHeap, 0, This.Ptr End If End Function
Public Function NextEntry( _ ByRef This As IEnumVariantType, _ ByVal celt As Long, _ ByRef rgvar As Variant, _ ByVal pceltFetched As Long _
) As Long If celt = 0 Then celt = 1
GetEnumerator(This.Ref).OnNextItem celt, rgvar, pceltFetched, This.Data
Rem If quantity of returned items is lower than what has been asked, iteration is over. If pceltFetched < celt Then NextEntry = 1 End Function
Public Function SkipEntry(ByRef This As IEnumVariantType, ByVal celt As Long) As Long
GetEnumerator(This.Ref).OnSkip celt, This.Data End Function
Public Function ResetEntry(ByRef This As IEnumVariantType) As Long
GetEnumerator(This.Ref).OnReset This.Data End Function
Public Function CloneEntry(ByRef This As IEnumVariantType, ByRef ppEnum As IEnumVARIANT) As Long
GetEnumerator(This.Ref).OnClone ppEnum, This.Data End Function
Private Function GetEnumerator(ByRef Ptr As LongPtr) As VariantEnumerator Dim Obj As VariantEnumerator Dim Res As VariantEnumerator Dim Nil As LongPtr
Rem Copy pointer to a temporary object.
CopyMemory Destination:=Obj, Source:=VarPtr(Ptr), Length:=Len(Ptr)
Rem Get the legal object. Set Res = Obj
Rem Free the ilegal object.
CopyMemory Destination:=Obj, Source:=VarPtr(Nil), Length:=Len(Nil)
Rem Return the "rehydrated" object. Set GetEnumerator = Res End Function
Private Sub DecRefCount(ByRef Ptr As LongPtr) Dim Dummy As Object
CopyMemory Destination:=ObjPtr(Dummy), Source:=Ptr, Length:=Len(Ptr) End Sub End Module
Public Module Vocabulary Option Explicit
Rem Contextual in VB6 Public Property Get vAccess() As String
vAccess = "Access" End Property
Public Property Get vAddressOf() As String
vAddressOf = "AddressOf" End Property
Rem Contextual in VB6 Public Property Get vAlias() As String
vAlias = "Alias" End Property
Public Property Get vAnd() As String
vAnd = "And" End Property
Rem New! Public Property Get vAndAlso() As String
vAndAlso = "AndAlso" End Property
Public Property Get vAny() As String
vAny = "Any" End Property
Rem Contextual in VB6 Public Property Get vAppend() As String
vAppend = "Append" End Property
Public Property Get vAs() As String
vAs = "As" End Property
Public Property Get vAttribute() As String
vAttribute = "Attribute" End Property
Rem Contextual in VB6 Public Property Get vBase() As String
vBase = "Base" End Property
Rem Contextual in VB6 Public Property Get vBinary() As String
vBinary = "Binary" End Property
Public Property Get vBoolean() As String
vBoolean = "Boolean" End Property
Public Property Get vByRef() As String
vByRef = "ByRef" End Property
Public Property Get vByVal() As String
vByVal = "ByVal" End Property
Public Property Get vByte() As String
vByte = "Byte" End Property
Public Property Get vCall() As String
vCall = "Call" End Property
Public Property Get vCase() As String
vCase = "Case" End Property
Public Property Get vCDecl() As String
vCDecl = "CDecl" End Property
Public Property Get vCircle() As String
vCircle = "Circle" End Property
Rem New! Public Property Get vClass() As String
vClass = "Class" End Property
Public Property Get vClose() As String
vClose = "Close" End Property
Rem Contextual in VB6 Public Property Get vCompare() As String
vCompare = "Compare" End Property
Public Property Get vConst() As String
vConst = "Const" End Property
Rem New! Public Property Get vContinue() As String
vContinue = "Continue" End Property
Public Property Get vCurrency() As String
vCurrency = "Currency" End Property
Public Property Get vDate() As String
vDate = "Date" End Property
Public Property Get vDecimal() As String
vDecimal = "Decimal" End Property
Public Property Get vDebug() As String
vDebug = "Debug" End Property
Public Property Get vDeclare() As String
vDeclare = "Declare" End Property
Rem New! Public Property Get vDefault() As String
vDefault = "Default" End Property
Public Property Get vDefBool() As String
vDefBool = "DefBool" End Property
Public Property Get vDefByte() As String
vDefByte = "DefByte" End Property
Public Property Get vDefCur() As String
vDefCur = "DefCur" End Property
Public Property Get vDefDate() As String
vDefDate = "DefDate" End Property
Public Property Get vDefDbl() As String
vDefDbl = "DefDbl" End Property
Public Property Get vDefDec() As String
vDefDec = "DefDec" End Property
Public Property Get vDefInt() As String
vDefInt = "DefInt" End Property
Public Property Get vDefLng() As String
vDefLng = "DefLng" End Property
Rem New! Public Property Get vDefLngLng() As String
vDefLngLng = "DefLngLng" End Property
Rem New! Public Property Get vDefLngPtr() As String
vDefLngPtr = "DefLngPtr" End Property
Public Property Get vDefObj() As String
vDefObj = "DefObj" End Property
Public Property Get vDefSng() As String
vDefSng = "DefSng" End Property
Public Property Get vDefStr() As String
vDefStr = "DefStr" End Property
Public Property Get vDefVar() As String
vDefVar = "DefVar" End Property
Public Property Get vDim() As String
vDim = "Dim" End Property
Public Property Get vDo() As String
vDo = "Do" End Property
Public Property Get vDouble() As String
vDouble = "Double" End Property
Public Property Get vEach() As String
vEach = "Each" End Property
Public Property Get vElseIf() As String
vElseIf = "ElseIf" End Property
Public Property Get vElse() As String
vElse = "Else" End Property
Public Property Get vEmpty() As String
vEmpty = "Empty" End Property
Public Property Get vEnd() As String
vEnd = "End" End Property
Public Property Get vEndIf() As String
vEndIf = "EndIf" End Property
Public Property Get vEnum() As String
vEnum = "Enum" End Property
Public Property Get vEqv() As String
vEqv = "Eqv" End Property
Public Property Get vErase() As String
vErase = "Erase" End Property
Rem Contextual in VB6 Public Property Get vError() As String
vError = "Error" End Property
Public Property Get vEvent() As String
vEvent = "Event" End Property
Public Property Get vExit() As String
vExit = "Exit" End Property
Rem Contextual in VB6 Public Property Get vExplicit() As String
vExplicit = "Explicit" End Property
Public Property Get vFalse() As String
vFalse = "False" End Property
Public Property Get vFor() As String
vFor = "For" End Property
Public Property Get vFriend() As String
vFriend = "Friend" End Property
Public Property Get vFunction() As String
vFunction = "Function" End Property
Public Property Get vGet() As String
vGet = "Get" End Property
Public Property Get vGlobal() As String
vGlobal = "Global" End Property
Public Property Get vGoSub() As String
vGoSub = "GoSub" End Property
Public Property Get vGoTo() As String
vGoTo = "GoTo" End Property
Public Property Get vIf() As String
vIf = "If" End Property
Public Property Get vImp() As String
vImp = "Imp" End Property
Public Property Get vImplements() As String
vImplements = "Implements" End Property
Public Property Get vIn() As String
vIn = "In" End Property
Public Property Get vInput() As String
vInput = "Input" End Property
Public Property Get vInteger() As String
vInteger = "Integer" End Property
Public Property Get vIs() As String
vIs = "Is" End Property
Rem New! Public Property Get vIsNot() As String
vIsNot = "IsNot" End Property
Rem New! Public Property Get vIterator() As String
vIterator = "Iterator" End Property
Public Property Get vLet() As String
vLet = "Let" End Property
Rem Contextual in VB6 Public Property Get vLib() As String
vLib = "Lib" End Property
Public Property Get vLike() As String
vLike = "Like" End Property
Rem Contextual in VB6 Public Property Get vLine() As String
vLine = "Line" End Property
Public Property Get vLock() As String
vLock = "Lock" End Property
Public Property Get vLocal() As String
vLocal = "Local" End Property
Public Property Get vLong() As String
vLong = "Long" End Property
Rem New! Public Property Get vLongPtr() As String
vLongPtr = "LongPtr" End Property
Rem New! Public Property Get vLongLong() As String
vLongLong = "LongLong" End Property
Public Property Get vLoop() As String
vLoop = "Loop" End Property
Public Property Get vLSet() As String
vLSet = "LSet" End Property
Public Property Get vLen() As String
vLen = "Len" End Property
Public Property Get vMe() As String
vMe = "Me" End Property
Public Property Get vMod() As String
vMod = "Mod" End Property
Rem Upgraded from contextual keyword (Option Private Module) to keyword Public Property Get vModule() As String
vModule = "Module" End Property
Rem Contextual in VB6 Public Property Get vName() As String
vName = "Name" End Property
Public Property Get vNew() As String
vNew = "New" End Property
Public Property Get vNext() As String
vNext = "Next" End Property
Public Property Get vNot() As String
vNot = "Not" End Property
Public Property Get vNothing() As String
vNothing = "Nothing" End Property
Public Property Get vNull() As String
vNull = "Null" End Property
Rem Contextual in VB6 Public Property Get vObject() As String
vObject = "Object" End Property
Public Property Get vOn() As String
vOn = "On" End Property
Public Property Get vOpen() As String
vOpen = "Open" End Property
Public Property Get vOption() As String
vOption = "Option" End Property
Public Property Get vOptional() As String
vOptional = "Optional" End Property
Public Property Get vOr() As String
vOr = "Or" End Property
Rem New! Public Property Get vOrElse() As String
vOrElse = "OrElse" End Property
Rem Contextual in VB6 Public Property Get vOutput() As String
vOutput = "Output" End Property
Public Property Get vParamArray() As String
vParamArray = "ParamArray" End Property
Public Property Get vPSet() As String
vPSet = "PSet" End Property
Public Property Get vPreserve() As String
vPreserve = "Preserve" End Property
Public Property Get vPrint() As String
vPrint = "Print" End Property
Public Property Get vPrivate() As String
vPrivate = "Private" End Property
Public Property Get vProperty() As String
vProperty = "Property" End Property
Rem New! Public Property Get vPtrSafe() As String
vPtrSafe = "PtrSafe" End Property
Public Property Get vPublic() As String
vPublic = "Public" End Property
Public Property Get vPut() As String
vPut = "Put" End Property
Public Property Get vRaiseEvent() As String
vRaiseEvent = "RaiseEvent" End Property
Rem Contextual in VB6 Public Property Get vRandom() As String
vRandom = "Random" End Property
Rem Contextual in VB6 Public Property Get vRead() As String
vRead = "Read" End Property
Public Property Get vReDim() As String
vReDim = "ReDim" End Property
Public Property Get vRem() As String
vRem = "Rem" End Property
Rem Contextual in VB6 Public Property Get vReset() As String
vReset = "Reset" End Property
Public Property Get vResume() As String
vResume = "Resume" End Property
Public Property Get vReturn() As String
vReturn = "Return" End Property
Public Property Get vRSet() As String
vRSet = "RSet" End Property
Public Property Get vSeek() As String
vSeek = "Seek" End Property
Public Property Get vSelect() As String
vSelect = "Select" End Property
Public Property Get vSet() As String
vSet = "Set" End Property
Public Property Get vScale() As String
vScale = "Scale" End Property
Public Property Get vShared() As String
vShared = "Shared" End Property
Public Property Get vSingle() As String
vSingle = "Single" End Property
Public Property Get vStatic() As String
vStatic = "Static" End Property
Rem Keyword in VB6, demoted to contextual Public Property Get vSpc() As String
vSpc = "Spc" End Property
Rem Contextual in VB6 Public Property Get vStep() As String
vStep = "Step" End Property
Rem Keyword in VB6, demoted to contextual Public Property Get vTab() As String
vTab = "Tab" End Property
Public Property Get vStop() As String
vStop = "Stop" End Property
Public Property Get vString() As String
vString = "String" End Property
Public Property Get vSub() As String
vSub = "Sub" End Property
Rem Contextual in VB6 Public Property Get vText() As String
vText = "Text" End Property
Public Property Get vThen() As String
vThen = "Then" End Property
Public Property Get vTo() As String
vTo = "To" End Property
Public Property Get vTrue() As String
vTrue = "True" End Property
Public Property Get vType() As String
vType = "Type" End Property
Public Property Get vTypeOf() As String
vTypeOf = "TypeOf" End Property
Public Property Get vUnlock() As String
vUnlock = "Unlock" End Property
Public Property Get vUntil() As String
vUntil = "Until" End Property
Public Property Get vVariant() As String
vVariant = "Variant" End Property
Public Property Get vVoid() As String Rem Intentionally blank End Property
Public Property Get vWend() As String
vWend = "Wend" End Property
Public Property Get vWhile() As String
vWhile = "While" End Property
Rem Contextual in VB6 Public Property Get vWidth() As String
vWidth = "Width" End Property
Public Property Get vWith() As String
vWith = "With" End Property
Public Property Get vWithEvents() As String
vWithEvents = "WithEvents" End Property
Public Property Get vWrite() As String
vWrite = "Write" End Property
Public Property Get vXor() As String
vXor = "Xor" End Property End Module