Metamorphing Machine
I rather be this walking metamorphosis than having that old formed opinion about everything!
Let's build a transpiler! Part 38
This is the thirty-eighth post in a series of building a transpiler.
You can find the previous ones here.
They don't want you to know
Hey, you. Yes, you! Would like to be around the cool guys and play with pointers?
Whaaa...? No, they're not dangerous.
That's what they say so you won't try what they don't want you to try.
Who are they you ask me? You know who they are... Theeey.
Anyways, you want it or not? If you don't, there are many people out there who wants. Don't make me waste my time.
OK, I'll give you some for free. Try VarPtr. With this function, you can get the address of any variable.
Well, not any variable. Most variables. Not array variables. Arrays are trouble makers. Objects have their own clique, too. You need to use ObjPtr with 'em.
Yeah, yeah, I know VB's help don't mention any of 'em. They don't want you to know, remember? But they are there. Hidden in plain sight.
When you're good with VarPtr and ObjPtr, you can start with StrPtr.
It don't give you the address of the variable, but the address that the address is pointing to. How cool is that, amirite?
What do you mean by "What if all I have is an array variable?"
Then you'd Declare a... Whoa... Is that an AddressOf there I'm seein'?.
Know what? I'm outta here, man. You're bananas!
Back to business
Last time I said we'll start cleaning up some pending items before starting to transpile for real.
Coming from the last post, I've changed not only Messages from module to class but also Vocabulary from module to class.
I gave a little love to Messages too, removing duplicates and giving each message a real name, not that Msg001 thing.
Apart from that, I removed passing Entity as an argument where it was not needed, but then I created a ControlPanel class.
This class will be used to check if some statements are legal.
For instance, if we parse a Continue Do, we need to be sure we are inside a Do/Loop.
So, whenever we parse a Do, we'll increment a counter in (Control)Panel. When parsing a Continue Do, we check that counter.
If it is zero, we have an illegal statement.
We'll do the same to Continue While/For, Exit Do/For/While, and something similar to Exit Sub/Function/Property.
I was also planning to use Panel to match GoTo/GoSub targets with actual line numbers and labels, but it did not work as expected. I need to improve it a bit before disclosing it.
Another code I worked on was in classifying number literals.
I suspect we'll have to know every variable and literal types in fine detail to succeed in transpiling VB code. So I started with literal numbers.
VB has an inconsistency related to that: -32768 hexadecimal representation is &H8000, but if you try the snippet below, you'll get False as an answer:
Debug.Print TypeName(-32768) = TypeName(&H8000)
&H8000's type is Integer, but -32768 is Long even though -32768 is within Integer's value range. Why is that?
I suppose that's because VB parses the minus operator and then the number - just like we are doing. Positive 32768 is not a valid Integer number - it is a Long one.
The same goes for &H80000000 and -2147483648. The former is Long, the latter is Double.
I don't want to perpetuate it, so here is my plan:
When parsing an integer literal, append a plus sign ("+") to its left.
Classify it as an Integer, Long, or LongLong.
Find a spot in code where we have an unambiguous negation sign (not a subtraction one) and check if it is being applied to an integer literal.
If it is, then merge the sign with the literal by changing that plus sign by a minus one.
If that plus sign has already been changed to a minus one, then restore the plus sign.
After merging the sign, reclassify it if needed. That's when we'll get an Integer out of that Long -32768.
The better place I could find to do that was in the Move method. Take a look there. Token's Code property will have a double duty:
For identifiers, it will be their index into NameBank. For integers, it will be their classification.
Another thing I should mention is that downgrading keywords in NextToken is not enough. My tests showed that sometimes it was too late.
I had to downgrade them in GetExpression too.
There was one keyword that proved hard to be "diminished", though: Rem.
Our parser does not handle "v.Rem" well. It thinks Rem is a keyword and thus "eats" everything after it as it was comment's text.
We cannot have v.Rem; it must be v.[Rem] instead. (This is in line with .NET, and I wonder if it is for the same reason.)
Finally, I will dump the whole code again, but with a twist: This is not valid VB6 code. It is using some new features like Continue and compound operators (i.e. "&=").
I did it to be able to test the parsing code feeding it with its own code. Due to that, I fixed a lot of bugs, and not all of them were retro-fixed.
Next week we'll go on risking things from our pending list.
Andrej Biasic
2021-06-09
Public Class AEIOU Option Explicit 'Assessment: Exists / Is Of Use Public Name As String Public IsDeclared As Boolean Public IsUsed As Boolean Public Token As Token End Class
Public Class AttributeConstruct Option Explicit
Public Id As Identifier Public Value As IExpression End Class
Public Class BinaryExpression Option Explicit Implements IExpression
Public LHS As IExpression Public Operator As Operator Public RHS As IExpression
Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekBinaryExpr End Property End Class
Public Class CallConstruct Option Explicit Implements IStmt Implements IExpression
Private Arguments_ As KeyedList
Public LHS As IExpression
Private Sub Class_Initialize() Set Arguments_ = New KeyedList Set Arguments_.T = New ExprValidator End Sub
Public Property Get Arguments() As KeyedList Set Arguments = Arguments_ End Property
Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekIndexer End Property
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snCall End Property End Class
Public Class CaseConstruct Option Explicit
Private Conditions_ As KeyedList Private Body_ As KeyedList
Private Sub Class_Initialize() Set Conditions_ = New KeyedList Set Conditions_.T = New ExprValidator
Set Body_ = New KeyedList Set Body_.T = New StmtValidator End Sub
Public Property Get Conditions() As KeyedList Set Conditions = Conditions_ End Property
Public Property Get Body() As KeyedList Set Body = Body_ End Property End Class
Public Class CloseConstruct Option Explicit Implements IStmt
Private FileNumbers_ As KeyedList
Private Sub Class_Initialize() Set FileNumbers_ = New KeyedList Set FileNumbers_.T = New ExprValidator End Sub
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snClose End Property
Public Property Get FileNumbers() As KeyedList Set FileNumbers = FileNumbers_ End Property End Class
Public Class ConstConstruct Option Explicit Implements IStmt
Public Access As Accessibility Public Id As Identifier Public DataType As DataType Public Value As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snConst End Property End Class
Public Class ContinueConstruct Option Explicit Implements IStmt
Public Enum ContinueWhat
cwDo
cwFor
cwWhile End Enum
Public What As ContinueWhat
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snContinue End Property End Class
Public Class ControlPanel Option Explicit
Public BodyType As Long Public DoCount As Long Public ForCount As Long Public WhileCount As Long Public SelectCount As Long Public Entity As Entity 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
If DfType Is Nothing Then Set DfType = New Token
DfType.Kind = tkKeyword
DfType.Code = kwVariant End If
Dim Index As Integer = ToIndex(Letter)
If A_Z_ Then Set Item = Letters_(0)
ElseIf Index = -1 OrElse 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 = ToIndex(FirstLetter) Dim Last As Integer = ToIndex(LastLetter)
If First > Last Then Dim Letter As Integer = First
First = Last
Last = Letter End If
A_Z_ = First = 0 AndAlso Last = LAST_INDEX
Dim Token As Token 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 Letters_(Letter) IsNot Nothing AndAlso Letters_(Letter).Text <> Token.Text Then Err.Raise 0 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 = AscW(Left$(Letter, 1)) If Result >= SMALL_A Then Result += CAPITAL_A - SMALL_A If Result < CAPITAL_A OrElse Result > CAPITAL_Z Then Result = CAPITAL_A - 1
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 Private Attributes_ 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
Set Attributes_ = New KeyedList Set Attributes_.T = NewValidator(TypeName(New AttributeConstruct)) End Sub
Public Static Property Get DefTypes() As DefType Dim Hidden As New DefType Set DefTypes = Hidden End Property
Public Property Get Consts() As KeyedList Set Consts = Consts_ End Property
Public Property Get Enums() As KeyedList Set Enums = Enums_ End Property
Public Property Get Declares() As KeyedList Set Declares = Declares_ End Property
Public Property Get Events() As KeyedList Set Events = Events_ End Property
Public Property Get Impls() As KeyedList Set Impls = Impls_ End Property
Public Property Get Vars() As KeyedList Set Vars = Vars_ End Property
Public Property Get Types() As KeyedList Set Types = Types_ End Property
Public Property Get Subs() As KeyedList Set Subs = Subs_ End Property
Public Property Get Functions() As KeyedList Set Functions = Funcs_ End Property
Public Property Get Properties() As KeyedList Set Properties = Props_ End Property
Public Property Get Attributes() As KeyedList Set Attributes = Attributes_ End Property 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 Vars_ As KeyedList
Private Sub Class_Initialize() Set Vars_ = New KeyedList Set Vars_.T = NewValidator(TypeName(New Symbol)) End Sub
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snErase End Property
Public Property Get Vars() As KeyedList Set Vars = Vars_ End Property End Class
Public Class EventConstruct Option Explicit
Private Parms_ As KeyedList
Public Id As Identifier
Private Sub Class_Initialize() Set Parms_ = New KeyedList Set Parms_.T = NewValidator(TypeName(New Parameter))
Parms_.CompareMode = vbTextCompare End Sub
Public Property Get Access() As Accessibility
Access = acPublic End Property
Public Property Get Parameters() As KeyedList Set Parameters = Parms_ End Property End Class
Public Class ExitConstruct Option Explicit Implements IStmt
Public Enum ExitWhat
ewDo
ewFor
ewFunction
ewProperty
ewSelect
ewSub
ewWhile End Enum
Public What As ExitWhat
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snExit End Property End Class
Public Class Expressionist Option Explicit
Private LastToken_ As Token
Public CanHaveTo As Boolean Public FullMode As Boolean
Public Property Get LastToken() As Token Set LastToken = LastToken_ End Property
Private Function Peek(ByVal Stack As KeyedList) As Variant Set Peek = Stack(Stack.Count) End Function
Private Function Pop(ByVal Stack As KeyedList) As Variant Dim Index As Long = 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 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 Dim WantOperand As Boolean = 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 opAddressOf, opAndAlso, opByVal, opIs, opIsNot, opLike, opNew, opNot, opOrElse, opTo, _
opTypeOf, opAnd, opEqv, opImp, opMod, opOr, opXor GoSub CheckDowngrade End Select
If Token.Kind <> tkOperator Then Set Token = Nothing Continue Do End If
Select Case Token.Code Case opSum
Token.Code = opId
Case opSubt
Token.Code = opNeg
Rem Unary operators Case opAddressOf, opNew, opNot, opTypeOf, opWithBang, opWithDot Exit Select
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 GoSub CheckDowngrade If Token.Kind = tkKeyword Then Exit Do End Select
Case Else Exit Do End Select Else If Parser.IsBreak(Token) Then While OpStack.Count > 0
Move OpStack, OutStack Wend
Exit Do End If
Select Case Token.Kind Case tkOperator
Down: Rem Unary and compound operators Select Case Token.Code Case opAddressOf, opNew, opNot, opTypeOf
Parser.Fail Token, x.InvExpr
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 Op
WantOperand = True
Case tkRightParenthesis Do While OpStack.Count > 0 Set Op = Peek(OpStack) If Op.Value.Kind = tkLeftParenthesis Then Exit Do
Move OpStack, OutStack, Op Loop
Rem It is allowed to not have a "(" on OpStack because we can be evaluating the following: Rem Sub A(Optional B As Integer = 1) Rem We'll get to ")" without having ")" on stack. If OpStack.Count = 0 Then Exit Do
Pop OpStack
Case tkKeyword If Token.Code <> kwTo Then Exit Do
If Not CanHaveTo OrElse 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 OrElse OutStack.Count = 1 AndAlso OpStack.Count > 0 Set Op = Peek(OpStack) If Op.Value.Kind = tkLeftParenthesis Then Exit Do
Move OpStack, OutStack, Op Loop
If OutStack.Count = 1 Then Set GetExpression = Pop(OutStack) Exit Function
CheckDowngrade: If Op Is Nothing Then Return If Op.IsUnary Or Op.Value.Code <> opDot And Op.Value.Code <> opBang Then Return
EnsureIdExists Token
Set Sym = New Symbol Set Sym.Value = Token
OutStack.Add Sym Return End Function
Private Sub Move(ByVal OpStack As KeyedList, ByVal OutStack As KeyedList, Optional ByVal Op As Operator) Dim Elem As Variant Dim Token As Token Dim Lit As Literal Dim IExpr As IExpression Dim Exec As CallConstruct Dim Tup As TupleConstruct Dim Uni As UnaryExpression Dim Bin As BinaryExpression
If Op Is Nothing Then Set Op = Peek(OpStack)
If Op.IsUnary Then Set Uni = New UnaryExpression Set Uni.Operator = Op Set Uni.Value = Pop(OutStack) Set IExpr = Uni
If Uni.Operator.Value.Code = opNeg AndAlso Uni.Value.Kind = ekLiteral Then Set Lit = Uni.Value
Select Case Lit.Value.Kind Case tkIntegerNumber, tkFloatNumber, tkSciNumber, tkBinaryNumber, tkOctalNumber, tkHexaNumber Set Token = Lit.Value
If Left$(Token.Text, 1) = "+"Then
Token.Text = "-" & Mid$(Token.Text, 2) Else
Token.Text = "+" & Mid$(Token.Text, 2) End If
Select Case Token.Code Case 0, vbInteger, vbLong, vbLongLong, vbDouble Select Case Token.Kind & Token.Text Case tkIntegerNumber & "-32768", _
tkBinaryNumber & "-1000000000000000", _
tkOctalNumber & "-100000", _
tkHexaNumber & "-8000"
Token.Code = vbInteger
Case tkIntegerNumber & "+9223372036854775808", _
tkBinaryNumber & "+1000000000000000000000000000000000000000000000000000000000000000", _
tkOctalNumber & "+1000000000000000000000", _
tkHexaNumber & "+8000000000000000"
Token.Code = vbDouble End Select End Select
Set IExpr = Lit End Select End If
ElseIf Op.Value.Code = opApply Then Set Exec = New CallConstruct Set Tup = Pop(OutStack)
For Each Elem In Tup.Elements
Exec.Arguments.Add Elem Next
Set Exec.LHS = Pop(OutStack) Set IExpr = Exec
Else Set Bin = New BinaryExpression Set Bin.Operator = Op Set Bin.RHS = Pop(OutStack) Set Bin.LHS = Pop(OutStack) Set IExpr = Bin End If
OutStack.Add IExpr
Pop OpStack End Sub
Public Function GetStmt(ByVal Parser As Parser, Optional ByVal Token As Token, Optional ByVal LookAhead As Token) As IStmt Dim Done As Boolean Dim Result As IStmt Dim Sym As Symbol Dim Name As IExpression Dim Asg As LetConstruct Dim Xp As Expressionist Dim Exec As CallConstruct Dim Uni As UnaryExpression Dim Bin As BinaryExpression
Set Xp = New Expressionist
If Token Is Nothing Then Set Token = Parser.NextToken
If Token.Kind = tkOperator Then If Token.Code = opWithBang OrElse Token.Code = opWithDot Then Set Uni = New UnaryExpression Set Uni.Operator = NewOperator(Token) Set Token = Parser.NextToken If Token.Kind <> tkIdentifier AndAlso Token.Kind <> tkEscapedIdentifier Then Stop
Set Sym = New Symbol Set Sym.Value = Token Set Uni.Value = Sym Set Name = Uni Else Stop End If End If
If Name Is Nothing Then Set Sym = New Symbol Set Sym.Value = Token Set Name = Sym End If
If LookAhead Is Nothing Then Set Token = Parser.NextToken Else Set Token = LookAhead End If
Do
Done = True
Select Case Token.Kind Case tkLeftParenthesis Set Exec = New CallConstruct Set Exec.LHS = Name Set Token = CollectArgs(Exec.Arguments, Parser) If Token.Kind = tkRightParenthesis Then Set Token = Parser.NextToken Set Name = Exec Rem Let's iterate again
Done = False
Case tkOperator Select Case Token.Code Case opAddressOf, opNew, opNot, opTypeOf, opWithDot, opWithBang Rem Operator is being passed to CollectArgs through Token argument. Set Exec = New CallConstruct Set Exec.LHS = Name Set Token = CollectArgs(Exec.Arguments, Parser, Token) Set Result = Exec
Case opDot Set Bin = New BinaryExpression Set Bin.Operator = NewOperator(Token) Set Bin.LHS = Name
Set Token = Parser.NextToken If Token.Kind <> tkIdentifier AndAlso 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 Set Asg.Value = Xp.GetExpression(Parser) Set Token = Xp.LastToken If Asg.Value Is Nothing Then Exit Do 'We'll return Nothing to sign a problem.
Set Result = Asg End Select
Case tkIdentifier, tkEscapedIdentifier Set Exec = New CallConstruct Set Exec.LHS = Name
Rem Identifier is being passed to CollectArgs through Token Set Token = CollectArgs(Exec.Arguments, Parser, Token) Set Result = Exec
Case tkKeyword Rem Keyword is being passed to CollectArgs through Token Select Case Token.Code Case kwByVal Set Exec = New CallConstruct Set Exec.LHS = Name Set Token = CollectArgs(Exec.Arguments, Parser, Token) Set Result = Exec
Case kwDate, kwString
Token.Kind = tkIdentifier Set Exec = New CallConstruct Set Exec.LHS = Name Set Token = CollectArgs(Exec.Arguments, Parser, Token) Set Result = Exec
Case kwEmpty, kwFalse, kwMe, kwNothing, kwNull, kwTrue Set Exec = New CallConstruct Set Exec.LHS = Name Set Token = CollectArgs(Exec.Arguments, Parser, Token) Set Result = Exec
Case Else Exit Do End Select
Case tkIntegerNumber, tkFloatNumber, tkSciNumber, tkBinaryNumber, _
tkOctalNumber, tkHexaNumber, tkString, tkDateTime Set Exec = New CallConstruct Set Exec.LHS = Name Rem Literal is being passed to CollectArgs through Token Set Token = CollectArgs(Exec.Arguments, Parser, Token) Set Result = Exec
Case tkListSeparator Set Exec = New CallConstruct Set Exec.LHS = Name Set Token = CollectArgs(Exec.Arguments, Parser, Token) Set Result = Exec
Case Else If Not Parser.IsBreak(Token) Then Exit Do
If Name.Kind = ekIndexer Then Set Exec = Name Else Rem Method call with no arguments. Set Exec = New CallConstruct Set Exec.LHS = Name End If
Set Result = Exec End Select Loop Until Done
Set LastToken_ = Token Set GetStmt = Result End Function
Friend Function CollectArgs(ByVal Args As KeyedList, ByVal Parser As Parser, Optional ByVal Token As Token) As Token Dim Tkn As Token Dim Lit As Literal Dim Expr As IExpression Dim Xp As Expressionist
Set Xp = New Expressionist
Xp.FullMode = True
If Token IsNot Nothing AndAlso 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
Do Set Expr = Xp.GetExpression(Parser, Token) Set Token = Xp.LastToken
If Expr Is Nothing Then Select Case Token.Kind Case tkRightParenthesis Exit Do
Case tkListSeparator Set Tkn = New Token
Tkn.Column = Token.Column
Tkn.Line = Token.Line
Tkn.Kind = tkKeyword
Tkn.Code = kwVoid
Set Lit = New Literal Set Lit.Value = Tkn Set Expr = Lit End Select End If
Args.Add Expr
If Token.Kind = tkRightParenthesis OrElse _
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_ -= 1 End Sub
Private Sub ITextBuilder_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 Private Attributes_ 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
Set Attributes_ = New KeyedList Set Attributes_.T = NewValidator(TypeName(New AttributeConstruct)) End Sub
Public Property Get Parameters() As KeyedList Set Parameters = Parms_ End Property
Public Property Get Body() As KeyedList Set Body = Body_ End Property
Public Property Get Attributes() As KeyedList Set Attributes = Attributes_ End Property End Class
Public Class GetConstruct Option Explicit Implements IStmt
Public FileNumber As IExpression Public RecNumber As IExpression Public Var As Symbol
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snGet End Property End Class
Public Class GoSubConstruct Option Explicit Implements IStmt
Public Target As IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snGoSub End Property End Class
Public Class GoToConstruct Option Explicit Implements IStmt
Public Target As IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snGoTo End Property End Class
Public Class 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 Name_ IsNot 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 Vars_ As KeyedList
Public FileNumber As IExpression
Private Sub Class_Initialize() Set Vars_ = New KeyedList Set Vars_.T = NewValidator(TypeName(New Symbol)) End Sub
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snInput End Property
Public Property Get Vars() As KeyedList Set Vars = Vars_ End Property End Class
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 Validator_ IsNot Nothing AndAlso 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_ += 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 FindNode(NewKey) IsNot 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_ += 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 = FindNode(Key) IsNot 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 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 PrvNode IsNot Nothing Then Set PrvNode.NextNode = CurNode.NextNode
Found = True Exit Do End If
Set PrvNode = CurNode Set CurNode = CurNode.NextNode Loop Else Dim Idx As Long = CLng(Index)
Idx -= Base
Do Until CurNode Is Nothing If Idx = 0 Then If CurNode Is Root_ Then Set Root_ = CurNode.NextNode
ElseIf PrvNode IsNot Nothing Then Set PrvNode.NextNode = CurNode.NextNode End If
If CurNode Is Last_ Then Set Last_ = PrvNode
Found = True Exit Do End If
Idx -= 1 Set PrvNode = CurNode Set CurNode = CurNode.NextNode Loop End If
If Found Then 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 Node As KLNode
If VarType(Index) = vbString Then Set Node = FindKey(CStr(Index)) Else Dim Idx As Long = CLng(Index)
Idx -= Base
If Idx >= 0 Then Set Node = Root_
Do Until Node Is Nothing OrElse Idx = 0 Set Node = Node.NextNode
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 += 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 = 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
Public 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_ += 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_ += Qty End Sub End Class
Public Class KLNode Option Explicit
Public NextNode As KLNode Public Key As String Public Value As Variant End Class
Public Class LabelConstruct Option Explicit Implements IStmt
Public Id As Identifier
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLabel End Property End Class
Public Class LetConstruct Option Explicit Implements IStmt
Public Name As IExpression Public Operator As Operator Public Value As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLet End Property End Class
Public Class LineNumberConstruct Option Explicit Implements IStmt
Public Value As Token
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLineNumber End Property End Class
Public Class Literal Option Explicit Implements IExpression
Public Value As Token
Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekLiteral End Property End Class
Public Class LockConstruct Option Explicit Implements IStmt
Public FileNumber As IExpression Public RecordRange As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLock End Property End Class
Public Class LSetConstruct Option Explicit Implements IStmt
Public Name As IExpression Public Value As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snLSet End Property End Class
Public Class Messages Option Explicit
Public Property Get PublicEtc() As String
PublicEtc = "Public, Private, Class, or Module" End Property
Public Property Get ClassModule() As String
ClassModule = "Class or Module" End Property
Public Property Get IdName() As String
IdName = "identifier" End Property
Public Property Get RuleEndEntity() As String
RuleEndEntity = "Rule: End (Class | Module)" End Property
Public Property Get AmbiguousName() As String
AmbiguousName = "Ambiguous name detected: " End Property
Public Property Get RuleEntityHeader() As String
RuleEntityHeader = "Rule: [Public | Private] (Class | Module) identifier" End Property
Public Property Get RuleIdHeader() As String
RuleIdHeader = "Rule: [Public | Private] identifier" End Property
Public Property Get RuleWrite() As String
RuleWrite = "Rule: Write #filenumber, [outputlist]" End Property
Public Property Get DuplOption() As String
DuplOption = "Duplicated Option statement" End Property
Public Property Get RuleOptionBase() As String
RuleOptionBase = "Rule: Option Base (0 | 1)" End Property
Public Property Get RuleEvent() As String
RuleEvent = "Rule: [Public] Event identifier [([parms])]" End Property
Public Property Get RuleOptionCompare() As String
RuleOptionCompare = "Rule: Option Compare (Binary | Text)" End Property
Public Property Get BinOrTxt() As String
BinOrTxt = "Binary or Text" End Property
Public Property Get RuleOption() As String
RuleOption = "Rule: Option (Base | Compare | Explicit)" End Property
Public Property Get ValidInClass() As String
ValidInClass = "Only valid inside Class" End Property
Public Property Get EventIsPublic() As String
EventIsPublic = "Event can only be Public" End Property
Public Property Get ExpOptEtc() As String
ExpOptEtc = "Expected: Option or Deftype or Public or Private or Const or Enum or Declare or Type" End Property
Public Property Get RuleDefType() As String
RuleDefType = "Rule: Deftype letter1[-letter2] [, ...]" End Property
Public Property Get Letter1() As String
Letter1 = "letter1" End Property
Public Property Get Letter2() As String
Letter2 = "letter2" End Property
Public Property Get DuplDefType() As String
DuplDefType = "Duplicated Deftype statement" End Property
Public Property Get RuleConst() As String
RuleConst = "Rule: [Public | Private] Const identifier [As datatype] = expression [, ...]" End Property
Public Property Get IdHasSygil() As String
IdHasSygil = "Identifier already has a type-declaration character" End Property
Public Property Get DataType() As String
DataType = "datatype" End Property
Public Property Get FixedLength() As String
FixedLength = "Fixed-length allowed only for String" End Property
Public Property Get CommaOrEOS() As String
CommaOrEOS = "list separator or end of statement" End Property
Public Property Get RuleEnum() As String
RuleEnum = "Rule: [Public | Private] Enum identifier" End Property
Public Property Get RuleType() As String
RuleType = "Rule: [Public | Private] Type identifier" End Property
Public Property Get EnumSygil() As String
EnumSygil = "Enum cannot have a type-declaration character" End Property
Public Property Get ExpAppendEtc() As String
ExpAppendEtc = "Expected: Append or Binary or Input or Random" End Property
Public Property Get RuleAssign() As String
RuleAssign = "Rule: identifier [= expression]" End Property
Public Property Get EnumerandSygil() As String
EnumerandSygil = "Enum member cannot have a type-declaration character" End Property
Public Property Get RuleEndEnum() As String
RuleEndEnum = "Rule: End Enum" End Property
Public Property Get EmptyEnum() As String
EmptyEnum = "Enum without members is not allowed" End Property
Public Property Get RuleDeclareHeader() As String
RuleDeclareHeader = "Rule: [Public | Private] Declare (Sub | Function) identifier [CDecl] " & _ "Lib lib_string [Alias alias_string] ([parms]) [As data_type[()]]" End Property
Public Property Get SubFunc() As String
SubFunc = "Sub or Function" End Property
Public Property Get LibString() As String
LibString = "lib string" End Property
Public Property Get AliasString() As String
AliasString = "alias string" End Property
Public Property Get Duplicated() As String
Duplicated = "Duplicated declaration in current scope" End Property
Public Property Get RuleParm() As String
RuleParm = "Rule: [[Optional] (ByVal | ByRef) | ParamArray] identifier[type_declaration_char][()] " & _ "[As datatype] [:= expression]" End Property
Public Property Get TooManyParms() As String
TooManyParms = "Too many formal parameters" End Property
Public Property Get OptParamArray() As String
OptParamArray = "Cannot have both Optional and ParamArray parameters" End Property
Public Property Get NoOptional() As String
NoOptional = "Optional not allowed" End Property
Public Property Get NoParamArray() As String
NoParamArray = "ParamArray not allowed" End Property
Public Property Get NoByval() As String
NoByval = "ByVal not allowed" End Property
Public Property Get NoByref() As String
NoByref = "ByRef not allowed" End Property
Public Property Get ParamIsArray() As String
ParamIsArray = "ParamArray must be declared as an array of Variant" End Property
Public Property Get AsPrjId() As String
AsPrjId = "As [project_name.]identifier" End Property
Public Property Get NonOptional() As String
NonOptional = "Parameter is not Optional" End Property
Public Property Get NoParamDefault() As String
NoParamDefault = "ParamArray cannot have a default value" End Property
Public Property Get ObjectName() As String
ObjectName = "object" End Property
Public Property Get ParensMismatch() As String
ParensMismatch = "Unclosed parenthesis" End Property
Public Property Get RuleImplements() As String
RuleImplements = "Rule: Implements [project_name.]identifier" End Property
Public Property Get PrjOrId() As String
PrjOrId = "Project name or identifier" End Property
Public Property Get NoSygil() As String
NoSygil = "Type-declaration character not allowed here" End Property
Public Property Get RuleDim() As String
RuleDim = "Rule: (Public | Private | Static | Dim) [WithEvents] identifier[type_declaration_character]" & _ "[([[n To] m[, ...]])] [As (data_type [= expression] | New class_name)] [, ...]" End Property
Public Property Get NoNew() As String
NoNew = "Invalid use of New" End Property
Public Property Get NotInsideMethod() As String
NotInsideMethod = "Invalid inside Sub, Function, or Property" End Property
Public Property Get InvExpr() As String
InvExpr = "Invalid expression" End Property
Public Property Get RuleWith() As String
RuleWith = "Rule: With object" End Property
Public Property Get RuleTypeMember() As String
RuleTypeMember = "Rule: member_name As data_type" End Property
Public Property Get RuleEndType() As String
RuleEndType = "Rule: End Type" End Property
Public Property Get RuleSubHeader() As String
RuleSubHeader = "Rule: [Public | Private | Friend] [Static] [Default] Sub identifier[([parms])]" End Property
Public Property Get RuleFuncHeader() As String
RuleFuncHeader = "Rule: [Public | Private | Friend] [Static] [Default] Function identifier[type_declaration_character]" & _ "[()][([parms])] [As datatype[()]]" End Property
Public Property Get RulePropHeader() As String
RulePropHeader = "Rule: [Public | Private | Friend] [Static] [Default] Property (Get | Let | Set) " & _ "identifier[type_declaration_character][()][([parms])] [As datatype[()]]" End Property
Public Property Get RuleEndSub() As String
RuleEndSub = "Rule: End Sub" End Property
Public Property Get RuleEndFunc() As String
RuleEndFunc = "Rule: End Function" End Property
Public Property Get RuleEndProp() As String
RuleEndProp = "Rule: End Property" End Property
Public Property Get ExpReadWrite() As String
ExpReadWrite = "Expected: Read or Write" End Property
Public Property Get GLSet() As String
GLSet = "Get or Let or Set" End Property
Public Property Get PropMismatch() As String
PropMismatch = "Definitions of property procedures for the same property are inconsistent, " & _ "or property procedure has an optional parameter, a ParamArray, or an invalid Set final parameter" End Property
Public Property Get ArgReqProp() As String
ArgReqProp = "Argument required for Property Let or Property Set" End Property
Public Property Get RuleFriendId() As String
RuleFriendId = "Rule: (Public | Private | Friend) identifier" End Property
Public Property Get DuplStatic() As String
DuplStatic = "Duplicated Static statement" End Property
Public Property Get DuplIterator() As String
DuplIterator = "Duplicated Iterator statement" End Property
Public Property Get DuplDefault() As String
DuplDefault = "Duplicated Default statement" End Property
Public Property Get NoDefaultIt() As String
NoDefaultIt = "A Function cannot be both Default and Iterator" End Property
Public Property Get ExpEqArg() As String
ExpEqArg = "Expected: = or argument" End Property
Public Property Get ExpEnd() As String
ExpEnd = "Expected: End " End Property
Public Property Get ExpGLSet() As String
ExpGLSet = "Expected: " & GLSet End Property
Public Property Get ExpStmt() As String
ExpStmt = "Expected: statement" End Property
Public Property Get RuleIf() As String
RuleIf = "Rule: If condition Then" End Property
Public Property Get ExpElseEtc() As String
ExpElseEtc = "Expected: Else or ElseIf or End If" End Property
Public Property Get NonEndIf() As String
NonEndIf = "Block If without End If" End Property
Public Property Get RuleSelect() As String
RuleSelect = "Rule: Select Case expression" End Property
Public Property Get ExpCompOp() As String
ExpCompOp = "Expected: > or >= or = or < or <= or <>" End Property
Public Property Get ExpIsElse() As String
ExpIsElse = "Expected: Is or Else" End Property
Public Property Get ExpDoEtc() As String
ExpDoEtc = "Expected: Do or For or While" End Property
Public Property Get ExpLoop() As String
ExpLoop = "Expected: Loop" End Property
Public Property Get RuleErase() As String
RuleErase = "Rule: Erase identifier" End Property
Public Property Get ExpDoForEtc() As String
ExpDoForEtc = "Expected: Do or For or Function or Property or Sub or Select or While" End Property
Public Property Get RuleFor() As String
RuleFor = "Rule: For identifier = start To end [Step increment]" End Property
Public Property Get Increment() As String
Increment = "increment" End Property
Public Property Get ExpNext() As String
ExpNext = "Expected: Next" End Property
Public Property Get RuleForEach() As String
RuleForEach = "Rule: For Each variable In group" End Property
Public Property Get VariableName() As String
VariableName = "variable" End Property
Public Property Get GroupName() As String
GroupName = "group" End Property
Public Property Get RuleGet() As String
RuleGet = "Rule: Get [#]filenumber, [recnumber], varname" End Property
Public Property Get WidthName() As String
WidthName = "width" End Property
Public Property Get RulePut() As String
RulePut = "Rule: Put [#]filenumber, [recnumber], varname" End Property
Public Property Get ExpTarget() As String
ExpTarget = "Expected: Label or line number" End Property
Public Property Get RuleInput() As String
RuleInput = "Rule: Input #filenumber, variable[, variable, ...]" End Property
Public Property Get HashFileNumber() As String
HashFileNumber = "#filenumber" End Property
Public Property Get RuleWidth() As String
RuleWidth = "Rule: Width #filenumber, width" End Property
Public Property Get RuleLock() As String
RuleLock = "Rule: Lock [#]filenumber[, recordrange]" End Property
Public Property Get RecordRange() As String
RecordRange = "recordrange" End Property
Public Property Get RuleLSet() As String
RuleLSet = "Rule: LSet variable = value" End Property
Public Property Get RuleRSet() As String
RuleRSet = "Rule: RSet variable = value" End Property
Public Property Get RuleName() As String
RuleName = "Rule: Name oldpathname As newpathname" End Property
Public Property Get OldPathName() As String
OldPathName = "oldpathname" End Property
Public Property Get NewPathName() As String
NewPathName = "newpathname" End Property
Public Property Get RuleOpen() As String
RuleOpen = "Rule: Open pathname For mode [Access access] [lock] As [#]filenumber [Len=reclength]" End Property
Public Property Get PathName() As String
PathName = "pathname" End Property
Public Property Get RulePrint() As String
RulePrint = "Rule: Print #filenumber, [outputlist]" End Property
Public Property Get ExpSubscript() As String
ExpSubscript = "Expected: subscript" End Property
Public Property Get RuleSeek() As String
RuleSeek = "Rule: Seek [#]filenumber, position" End Property
Public Property Get PositionName() As String
PositionName = "position" End Property
Public Property Get RuleUnlock() As String
RuleUnlock = "Rule: Unlock [#]filenumber[, recordrange]" End Property
Public Property Get RuleWhile() As String
RuleWhile = "Rule: While condition" End Property
Public Property Get ExpWend() As String
ExpWend = "Expected: Wend or End While" End Property
Public Property Get RuleAttribute() As String
RuleAttribute = "Rule: Attribute [varname.]identifier = expression" End Property
Public Property Get ExpVarId() As String
ExpVarId = "Expected: varname or identifier" End Property
Public Property Get ExpEq() As String
ExpEq = "Expected: " & Equal End Property
Public Property Get ExpExpr() As String
ExpExpr = "Expected: expression" End Property
Public Property Get ContinueNonDo() As String
ContinueNonDo = "Continue Do not within Do ... Loop" End Property
Public Property Get ContinueNonFor() As String
ContinueNonFor = "Continue For not within For ... Next" End Property
Public Property Get ContinueNonWhile() As String
ContinueNonWhile = "Continue While not within While ... Wend" End Property
Public Property Get ExitNonDo() As String
ExitNonDo = "Exit Do not within Do ... Loop" End Property
Public Property Get ExitNonFor() As String
ExitNonFor = "Exit For not within For ... Next" End Property
Public Property Get ExitNonWhile() As String
ExitNonWhile = "Exit While not within While ... Wend" End Property
Public Property Get ExitNonSub() As String
ExitNonSub = "Exit Sub not allowed in Function or Property" End Property
Public Property Get ExitNonFunc() As String
ExitNonFunc = "Exit Function not allowed in Sub or Property" End Property
Public Property Get ExitNonProp() As String
ExitNonProp = "Exit Property not allowed in Function or Sub" End Property
Public Property Get ExitNonSelect() As String
ExitNonSelect = "Exit Select not within Select ... End Select" End Property
Public Property Get ZeroOne() As String
ZeroOne = "0 or 1" End Property
Public Property Get Comma() As String
Comma = "," End Property
Public Property Get Equal() As String
Equal = "=" End Property
Public Property Get CloseParens() As String
CloseParens = ")" End Property
Public Property Get ExpEOS() As String
ExpEOS = "Expected: End of statement" End Property
Public Property Get InvLinNum() As String
InvLinNum = "Invalid line number" End Property
Public Property Get ExpGoToSub() As String
ExpGoToSub = "Expected: GoTo or GoSub" End Property
Public Property Get ExpGoToResume() As String
ExpGoToResume = "Expected: GoTo or Resume" End Property
Public Property Get ExpBaseEtc() As String
ExpBaseEtc = "Base or Explicit or Compare" End Property 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(TypeName(""))
Ids_.CompareMode = vbTextCompare
Ids_.Add V.String, V.String
Set Keywords_ = New KeyedList Set Keywords_.T = NewValidator(TypeName(""))
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
Public OldPathName As IExpression Public NewPathName As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snName End Property End Class
Public Class OnComputedConstruct Option Explicit Implements IStmt
Private Targets_ As KeyedList
Public Value As IExpression Public IsGoTo As Boolean
Private Sub Class_Initialize() Set Targets_ = New KeyedList Set Targets_.T = New StmtValidator End Sub
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snOnComputed End Property
Public Property Get Targets() As KeyedList Set Targets = Targets_ End Property End Class
Public Class OnErrorConstruct Option Explicit Implements IStmt
Public Statement As IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snOnError End Property End Class
Public Class OpenConstruct Option Explicit Implements IStmt
Public Enum FileModes
fmRandom
fmAppend
fmBinary
fmInput
fmOutput End Enum
Public Enum FileAccesses
faNone
faRead
faWrite
faReadWrite End Enum
Public Enum FileLocks
flShared
flRead
flWrite
flReadWrite End Enum
Public PathName As IExpression Public FileMode As FileModes Public FileAccess As FileAccesses Public FileLock As FileLocks Public FileNumber As IExpression Public Length As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snOpen End Property End Class
Public Class Operator Option Explicit
Public Value As Token
Public Property Get IsUnary() As Boolean Select Case Value.Code Case opAddressOf, opNew, opNot, opTypeOf, 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
EnsureIdExists Token
Else Select Case Token.Code Case kwAs
WasAs_ = True
Select Case State_ Case ncOpen03, ncOpen05, ncOpen06, ncOpen08, ncOpen09
State_ = ncOpen10 End Select
Case kwDate, kwString If Not WasAs_ Then EnsureIdExists Token
Case kwDeclare If State_ = ncNone Then State_ = ncDeclare
Case kwFor If State_ = ncNone Then
State_ = ncForNext
ElseIf State_ = ncOpen01 Then
State_ = ncOpen02 End If
Case kwInput If State_ = ncOpen02 Then State_ = ncOpen03
Case cxLock Select Case State_ Case ncOpen05, ncOpen06
State_ = ncOpen07 End Select
Case kwOpen If State_ = ncNone Then State_ = ncOpen01
Case kwOption If State_ = ncNone Then State_ = ncOption
Case kwOn If State_ = ncNone Then State_ = ncOn
Case cxShared Select Case State_ Case ncOpen03, ncOpen04, ncOpen06
State_ = ncOpen09 End Select
Case kwTo If State_ = ncForNext Then State_ = ncForTo
Case kwWrite Select Case State_ Case ncOpen04, ncOpen05
State_ = ncOpen06
Case ncOpen07, ncOpen08
State_ = ncOpen09 End Select End Select End If
Case tkIdentifier
Downgrade_ = False
WasAs_ = False
Select Case State_ Case ncNone Select Case Token.Code Case cxLine Set LookAhead_ = Scanner_.GetToken
Upgrade = LookAhead_.Kind = tkKeyword AndAlso LookAhead_.Code = kwInput
If Upgrade Then
Upgrade = LookAhead_.Kind <> tkKeyword OrElse LookAhead_.Code <> kwAs End If
If Upgrade Then Upgrade = LookAhead_.Kind <> tkOperator If Upgrade Then Upgrade = LookAhead_.Kind <> tkLeftParenthesis If Upgrade Then Upgrade = Not IsEndOfContext(LookAhead_) End If
Case cxWidth Set LookAhead_ = Scanner_.GetToken
Upgrade = LookAhead_.Kind = tkFileHandle End Select
Case ncOption
Upgrade = Token.Code = cxBase If Not Upgrade Then Upgrade = Token.Code = cxExplicit
If Not Upgrade Then
Upgrade = Token.Code = cxCompare If Upgrade Then State_ = ncOptionCompare End If
Case ncOptionCompare
Upgrade = Token.Code = cxBinary If Not Upgrade Then Upgrade = Token.Code = cxText
Case ncDeclare
Upgrade = Token.Code = cxPtrSafe
If Upgrade Then
State_ = ncDeclareLib Else
Upgrade = Token.Code = cxLib If Upgrade Then State_ = ncDeclareAlias End If
Case ncDeclareLib
Upgrade = Token.Code = cxLib If Upgrade Then State_ = ncDeclareAlias
Case ncDeclareAlias
Upgrade = Token.Code = cxAlias
Revoke = True
Case ncForTo
Upgrade = Token.Code = cxStep
Revoke = True
Case ncOn
Upgrade = Token.Code = cxError
Revoke = True
Case ncOpen02
Upgrade = Token.Code = cxAppend If Not Upgrade Then Upgrade = Token.Code = cxBinary If Not Upgrade Then Upgrade = Token.Code = cxOutput If Not Upgrade Then Upgrade = Token.Code = cxRandom
State_ = ncOpen03
Case ncOpen03
Upgrade = Token.Code = cxAccess If Upgrade Then State_ = ncOpen04
Case ncOpen05, ncOpen06
Upgrade = Token.Code = cxShared If Upgrade Then State_ = ncOpen09
Case ncOpen04
Upgrade = Token.Code = cxRead If Upgrade Then State_ = ncOpen05
Case ncOpen07
Upgrade = Token.Code = cxRead If Upgrade Then State_ = ncOpen08
Case ncOpen11
Upgrade = Token.Code = cxLen
Revoke = True End Select
Case tkFileHandle If State_ = ncOpen10 Then State_ = ncOpen11
Case tkLineContinuation If Not ForPrint Then Set Token = NextToken()
While IsBreak(Token) Set Token = NextToken() Wend End If
Case tkWhiteSpace
Done = False
Spaces += 1
Case tkSoftLineBreak, tkHardLineBreak
WasAs_ = False End Select
If Upgrade Then If Token.Suffix <> vbNullChar Then Fail Token, x.NoSygil
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 AndAlso 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, x.RuleEntityHeader, x.PublicEtc
Else
Fail Token, x.RuleEntityHeader, x.ClassModule End If
Set Mark = Token
If Entity.Accessibility = acLocal Then Entity.Accessibility = acPublic Set Token = NextToken If Not IsProperId(Token) Then Fail Token, x.RuleEntityHeader, x.IdName
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, x.RuleEndEntity, V.End End If
Set Token = NextToken If Not Token.IsKeyword(IIf(Entity.IsClass, kwClass, kwModule)) Then Fail Token, x.ExpEnd & NameBank(Mark)
Name = NameBank(Entity.Id.Name) If Source_.Entities.Exists(Name) Then Fail Entity.Id.Name, x.AmbiguousName & 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 KeepToken As Boolean Dim Text As String Dim Token As Token Dim Panel As ControlPanel Dim Access As Accessibility
Set Panel = New ControlPanel Set Panel.Entity = Entity
Do If Not KeepToken Then Set Token = SkipLineBreaks
KeepToken = False
If Token.Kind = tkKeyword Then Select Case Token.Code Case kwAttribute If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName Set Token = ParseAttributes(Entity.Attributes, Token)
KeepToken = True
Case kwOption If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName Set Token = NextToken If Token.Kind <> tkKeyword Then Fail Token, x.RuleOption, x.ExpBaseEtc
Select Case Token.Code Case cxBase If HadBase Then Fail Token, x.DuplOption
HadBase = True
Set Token = NextToken
If Token.Kind <> tkIntegerNumber OrElse (Token.Text <> "+0"AndAlso Token.Text <> "+1") Then
Fail Token, x.RuleOptionBase, x.ZeroOne End If
Entity.OptionBase = IIf(Text = "+0", 0, 1)
Case cxCompare If HadCompare Then Fail Token, x.DuplOption
HadCompare = True
Set Token = NextToken If Token.Kind <> tkKeyword Then Fail Token, x.RuleOptionCompare, x.BinOrTxt
Select Case Token.Code Case cxBinary
Entity.OptionCompare = vbBinaryCompare
Case cxText
Entity.OptionCompare = vbTextCompare
Case Else
Fail Token, x.RuleOptionCompare, x.BinOrTxt End Select
Case cxExplicit If Entity.OptionExplicit Then Fail Token, x.DuplOption
Entity.OptionExplicit = True
Case Else
Fail Token, x.RuleOption, V.Option End Select
Case kwDefBool If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbBoolean, Entity
Case kwDefByte If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbByte, Entity
Case kwDefInt If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbInteger, Entity
Case kwDefLng If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbLong, Entity
Case kwDefLngLng If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbLongLong, Entity
Case kwDefLngPtr If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbLongPtr, Entity
Case kwDefCur If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbCurrency, Entity
Case kwDefDec If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbDecimal, Entity
Case kwDefSng If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbSingle, Entity
Case kwDefDbl If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbDouble, Entity
Case kwDefDate If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbDate, Entity
Case kwDefStr If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbString, Entity
Case kwDefObj If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbObject, Entity
Case kwDefVar If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseDef vbVariant, Entity
Case kwPublic, kwGlobal If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
Access = acPublic
Case kwPrivate If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
Access = acPrivate
Case kwConst If Access = acLocal Then Access = acPrivate
ParseConsts Access, Panel, Entity.Consts
Access = acLocal
Case kwEnum
ParseEnum Access, Panel
Access = acLocal
Case kwDeclare
ParseDeclare Access, Panel
Access = acLocal
Case kwEvent If Not Entity.IsClass Then Fail Token, x.ValidInClass If Access = acLocal Then Access = acPublic If Access <> acPublic Then Fail Token, x.EventIsPublic
ParseEvent Panel
Access = acLocal
Case kwImplements If Not Entity.IsClass Then Fail Token, x.ValidInClass If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName
ParseImplements Entity
Case kwWithEvents If Access = acLocal Then Access = acPublic
ParseDim Access, Panel, Entity.Vars, Token:=Token
Access = acLocal
Case kwDim If Access = acLocal Then Access = acPublic
ParseDim Access, Panel, Entity.Vars
Access = acLocal
Case kwType If Access = acLocal Then Access = acPublic
ParseType Access, Panel
Access = acLocal
Case kwFriend If Access <> acLocal Then Fail Token, x.RuleIdHeader, x.IdName If Not Entity.IsClass Then Fail Token, x.ValidInClass
Access = acFriend Exit Do
Case kwStatic, kwIterator, kwDefault, kwSub, kwFunction, cxProperty, kwEnd Exit Do
Case Else
Fail Token, x.ExpOptEtc End Select
ElseIf Token.IsId(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 Panel As ControlPanel Dim Func As FunctionConstruct Dim Prop As PropertyConstruct
Dim Access As Accessibility = AccessToken.Access Set Token = AccessToken.Token
Do While Token.Kind = tkKeyword Select Case Token.Code Case kwPublic If Access <> acLocal Then Fail Token, x.RuleFriendId, x.IdName
Access = acPublic
Case kwPrivate If Access <> acLocal Then Fail Token, x.RuleFriendId, x.IdName
Access = acPrivate
Case kwFriend If Access <> acLocal Then Fail Token, x.RuleFriendId, x.IdName
Access = acFriend
Case kwDefault If IsDefault OrElse HadDefault Then Fail Token, x.DuplDefault
HadDefault = True
IsDefault = True
Case kwIterator If IsIterator OrElse HadIterator Then Fail Token, x.DuplIterator
HadIterator = True
IsIterator = True
Case kwStatic If IsStatic Then Fail Token, x.DuplStatic
IsStatic = True
Case kwSub Set Panel = New ControlPanel Set Panel.Entity = Entity
Panel.BodyType = ewSub
Set Token = SkipLineBreaks If Token.IsId(cxProperty) Then Token.Kind = tkKeyword Loop
Set ParseProcedureArea = Token Exit Function
Cleanup:
IsStatic = False
IsDefault = False
IsIterator = False
Access = acLocal Return 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, x.RuleDefType, x.Letter1 If Token.Suffix <> vbNullChar Then Fail Token, x.NoSygil
First = NameBank(Token) Set Token = NextToken
If Token.IsOperator(opSubt) Then Set Token = NextToken If Token.Kind <> tkIdentifier OrElse Token.Suffix <> vbNullChar Then Fail Token, x.RuleDefType, x.Letter2
Last = NameBank(Token) Set Token = NextToken Else
Last = First End If
On Error Resume Next
Entity.DefTypes.SetRange First, Last, VariableType
If Err Then On Error GoTo 0
Fail Token, x.DuplDefType End If
On Error GoTo 0
If IsBreak(Token) Then Exit Do If Token.Kind <> tkListSeparator Then Fail Token, x.RuleDefType, x.Comma Loop End Sub
Private Function ParseConsts( _ ByVal Access As Accessibility, _ ByVal Panel As ControlPanel, _ ByVal Body As KeyedList, _ Optional ByVal InsideProc As Boolean _
) As Token Dim Name As String Dim 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, x.RuleConst, x.IdName
Set Cnt = New ConstConstruct
Cnt.Access = Access Set Cnt.Id = NewId(Token)
Set Token = NextToken
Rem Do we have an As clause? If Token.IsKeyword(kwAs) Then If Token.Suffix <> vbNullChar Then Fail Token, x.IdHasSygil
Rem Get Const's data type name Set Token = NextToken If Not IsConstDataType(Token) Then Fail Token, x.RuleConst, x.DataType
Set Cnt.DataType = NewDataType(Token) Set Token = NextToken
If Token.IsOperator(opMul) Then If Cnt.DataType.Id.Name <> V.String Then Fail Token, x.FixedLength
Set Cnt.DataType.FixedLength = Xp.GetExpression(Me) Set Token = Xp.LastToken If Cnt.DataType.FixedLength Is Nothing Then Fail Token, x.InvExpr End If
ElseIf Cnt.Id.Name.Suffix <> vbNullChar Then Rem Assign DataType property based on type sufix Set Cnt.DataType = FromChar(Cnt.Id.Name.Suffix) End If
Rem Discard "=" If Not Token.IsOperator(opEq) Then Fail Token, x.RuleConst, x.Equal
Rem Get Const's value Set Cnt.Value = Xp.GetExpression(Me) If Cnt.Value Is Nothing Then Fail Token, x.InvExpr
Rem Ensure it's not a duplicated Const If Not InsideProc Then CheckDupl Panel.Entity, Cnt.Id.Name
Name = NameBank(Cnt.Id.Name) If Body.Exists(Name) Then Fail Cnt.Id.Name, x.AmbiguousName & 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, x.RuleConst, x.CommaOrEOS Loop
Set ParseConsts = Token End Function
Private Sub ParseEnum(ByVal Access As Accessibility, ByVal Panel As ControlPanel) 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, x.RuleEnum, x.IdName If Token.Suffix <> vbNullChar Then Fail Token, x.EnumSygil
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, x.ExpEOS
Do Set Token = SkipLineBreaks If Token.IsKeyword(kwEnd) Then Exit Do If Not IsProperId(Token) Then Fail Token, x.RuleAssign, x.IdName If Token.Suffix <> vbNullChar Then Fail Token, x.EnumerandSygil
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, x.InvExpr End If
If Enm.Enumerands.Exists(NameBank(Emd.Id.Name)) Then Fail Emd.Id, x.AmbiguousName & NameBank(Emd.Id.Name)
Enm.Enumerands.AddKeyValue NameBank(Emd.Id.Name), Emd Loop While IsBreak(Token)
If Not Token.IsKeyword(kwEnd) Then Fail Token, x.RuleEndEnum, V.End
Set Token = NextToken If Not Token.IsKeyword(kwEnum) Then Fail Token, x.RuleEndEnum, V.Enum
MustEatLineBreak
If Enm.Enumerands.Count = 0 Then Fail Enm, x.EmptyEnum
CheckDupl Panel.Entity, Enm.Id.Name
Panel.Entity.Enums.AddKeyValue NameBank(Enm.Id.Name), Enm End Sub
Private Sub ParseDeclare(ByVal Access As Accessibility, ByVal Panel As ControlPanel) Dim Token As Token Dim Tkn As Token Dim Dcl As DeclareConstruct
Set Dcl = New DeclareConstruct If Access = acLocal Then Access = acPublic
Dcl.Access = Access
Rem Is it PtrSafe? Set Token = NextToken
If Token.IsKeyword(cxPtrSafe) Then Rem Just ignore it Set Token = NextToken End If
Rem Is it a Sub or a Function? If Token.IsKeyword(kwSub) Then Rem It is a Sub
Dcl.IsSub = True
ElseIf Token.IsKeyword(kwFunction) Then Rem It is a Function
Dcl.IsSub = False 'Technically this is not needed.
Else Rem It is not a Sub nor a Function
Fail Token, x.RuleDeclareHeader, x.SubFunc End If
Rem Get its name. Set Token = NextToken If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, x.RuleDeclareHeader, x.IdName
Set Dcl.Id = NewId(Token)
Rem Maybe there is a CDecl? Set Token = NextToken
If Token.IsKeyword(kwCDecl) Then
Dcl.IsCDecl = True Set Token = NextToken End If
Rem Discard Lib If Not Token.IsKeyword(cxLib) Then Fail Token, x.RuleDeclareHeader, V.Lib
Rem Get Lib's name Set Token = NextToken If Token.Kind <> tkString Then Fail Token, x.RuleDeclareHeader, x.LibString Set Dcl.LibName = Token
Rem Maybe there is an Alias? Set Token = NextToken
If Token.IsKeyword(cxAlias) Then Rem Get Alias' name Set Token = NextToken If Token.Kind <> tkString Then Fail Token, x.RuleDeclareHeader, x.AliasString
Set Dcl.AliasName = Token Set Token = NextToken End If
Rem Get its parameters. If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Panel, skDeclare, Dcl.Parameters)
Rem Maybe there's an "As" clause? If Token.IsKeyword(kwAs) Then Rem Can we have an "As" clause? If Dcl.IsSub Then Fail Token, x.ExpEOS If Token.Suffix <> vbNullChar Then Fail Token, x.IdHasSygil
Rem Get data type name Set Token = NextToken
Select Case Token.Kind Case tkIdentifier, tkEscapedIdentifier If Token.Suffix <> vbNullChar Then Fail Token, x.NoSygil Set Dcl.DataType = NewDataType(Token) Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Not IsProperId(Token) Then Fail Token, x.RuleDeclareHeader, x.DataType
Set Dcl.DataType.Id.Name = Token Set Token = NextToken End If
Case tkKeyword If Not IsBuiltinDataType(Token) Then Fail Token, x.RuleDeclareHeader, x.DataType Set Dcl.DataType = NewDataType(Token) Set Token = NextToken
Case Else
Fail Token, x.RuleDeclareHeader, x.DataType End Select
Rem Maybe it returns an array? If Token.Kind = tkLeftParenthesis Then Set Token = NextToken If Token.Kind <> tkRightParenthesis Then Fail Token, x.ParensMismatch
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 = Panel.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 Panel.Entity, Dcl.Id.Name
Rem Must end with a line break If Not IsBreak(Token) Then MustEatLineBreak
Panel.Entity.Declares.AddKeyValue NameBank(Dcl.Id.Name), Dcl End Sub
Private Function ParseParms( _ ByVal Panel As ControlPanel, _ 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 += 1 If Index >= 60 Then Fail Token, x.TooManyParms
If Token.IsKeyword(kwOptional) Then If LastParm.IsParamArray Then Fail Token, x.OptParamArray If SignatureKind = skEvent OrElse SignatureKind = skTuple Then Fail Token, x.NoOptional
CurrParm.IsOptional = True Set Token = NextToken
ElseIf Token.IsKeyword(kwParamArray) Then If LastParm.IsOptional Then Fail Token, x.OptParamArray If SignatureKind = skEvent OrElse SignatureKind = skTuple Then Fail Token, x.NoParamArray
CurrParm.IsParamArray = True Set Token = NextToken End If
If Not CurrParm.IsParamArray Then If Token.IsKeyword(kwByVal) Then If SignatureKind = skTuple Then Fail Token, x.NoByval
CurrParm.IsByVal = True Set Token = NextToken
ElseIf Token.IsKeyword(kwByRef) Then If SignatureKind = skTuple Then Fail Token, x.NoByref
CurrParm.IsByVal = False 'Technically this is not needed Set Token = NextToken End If End If
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, x.RuleParm, x.IdName Set CurrParm.Id = NewId(Token)
Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = NextToken If Token.Kind <> tkRightParenthesis Then Fail Token, x.RuleParm, x.CloseParens
CurrParm.IsArray = True Set Token = NextToken End If
If CurrParm.IsParamArray AndAlso Not CurrParm.IsArray Then Fail CurrParm.Id, x.ParamIsArray
If Token.IsKeyword(kwAs) Then If CurrParm.Id.Name.Suffix <> vbNullChar Then Fail Token, x.IdHasSygil Set Token = NextToken
If SignatureKind = skDeclare Then If Not IsDataType(Token) Then Fail Token, x.RuleParm, x.DataType Else If Not IsProperDataType(Token) Then Fail Token, x.RuleParm, x.DataType End If
Set CurrParm.DataType = NewDataType(Token) Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Not IsProperId(Token) Then Fail Token, x.AsPrjId, x.IdName
Set CurrParm.DataType.Id.Name = Token
If CurrParm.IsParamArray AndAlso ( _
CurrParm.DataType.Id.Project IsNot Nothing OrElse _
CurrParm.DataType.Id.Name.Code <> kwVariant) Then _
Fail Token, x.ParamIsArray
Set Token = NextToken End If
ElseIf CurrParm.Id.Name.Suffix <> vbNullChar Then Set CurrParm.DataType = FromChar(CurrParm.Id.Name.Suffix)
Else Set CurrParm.DataType = Panel.Entity.DefTypes(NameBank(CurrParm.Id.Name)) End If
If Token.IsOperator(opEq) Then If Not CurrParm.IsOptional Then Fail Token, x.NonOptional If CurrParm.IsParamArray Then Fail Token, x.NoParamDefault Set CurrParm.Init = Xp.GetExpression(Me) Set Token = Xp.LastToken If CurrParm.Init Is Nothing Then Fail Token, x.InvExpr End If
If Not CurrParm.IsOptional AndAlso (LastParm.IsOptional Or LastParm.IsParamArray) Then If SignatureKind <> skPropertyLet AndAlso SignatureKind <> skPropertySet Then _
Fail CurrParm.Id, x.RuleParm, V.Optional
GoSub AddParm Set Token = NextToken Exit Do End If
GoSub AddParm Set LastParm = CurrParm If Token.Kind <> tkListSeparator Then Exit Do Set Token = NextToken Loop End If
If SignatureKind = skPropertyLet OrElse SignatureKind = skPropertySet Then If Parms.Count = 0 Then
Fail Token, x.ArgReqProp
ElseIf LastParm.IsOptional OrElse LastParm.IsParamArray Then
Fail LastParm.Id, x.ArgReqProp End If End If
If Token.Kind <> tkRightParenthesis Then Fail Token, x.ParensMismatch Set ParseParms = NextToken Exit Function
AddParm:
Name = NameBank(CurrParm.Id.Name)
If Parms.Exists(Name) Then If SignatureKind <> skDeclare Then Fail CurrParm.Id, x.Duplicated
Count = 1
Do
Name = NameBank(CurrParm.Id.Name) & "_" & CStr(Count) If Not Parms.Exists(Name) Then Exit Do
Count += 1 Loop End If
Parms.AddKeyValue Name, CurrParm If SignatureKind <> skDeclare AndAlso SignatureKind <> skEvent Then Panel.AddVar CurrParm Return End Function
Private Sub ParseEvent(ByVal Panel As ControlPanel) Dim Token As Token Dim Evt As EventConstruct
Set Token = SkipLineBreaks If Not IsProperId(Token) Then Fail Token, x.RuleEvent, x.IdName
Set Evt = New EventConstruct Set Evt.Id = NewId(Token)
Set Token = NextToken If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Panel, skEvent, Evt.Parameters)
If Not IsBreak(Token) Then Fail Token, x.ExpEOS
CheckDupl Panel.Entity, Evt.Id.Name
Panel.Entity.Events.AddKeyValue NameBank(Evt.Id.Name), Evt End Sub
Private Sub ParseImplements(ByVal Entity As Entity) Dim Token As Token Dim Impls As ImplementsConstruct
Set Token = SkipLineBreaks If Token.Kind <> tkIdentifier Then Fail Token, x.RuleImplements, x.PrjOrId If Token.Suffix <> vbNullChar Then Fail Token, x.NoSygil
Set Impls = New ImplementsConstruct Set Impls.Id.Name = Token
Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Token.Kind <> tkIdentifier Then Fail Token, x.RuleImplements, x.IdName If Token.Suffix <> vbNullChar Then Fail Token, x.NoSygil
Set Impls.Id.Name = Token Set Token = NextToken End If
If Not IsBreak(Token) Then Fail Token, x.ExpEOS Set Token = Impls.Id.Name Dim Name As String = NameBank(Token) If Entity.Impls.Exists(Name) Then Fail Token, x.AmbiguousName & Name
Entity.Impls.Add Impls, Name End Sub
Private Function ParseSub(ByVal Access As Accessibility, ByVal Panel As ControlPanel) As SubConstruct 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, x.RuleSubHeader, x.IdName
Set Proc.Id = NewId(Token) Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Panel, skSub, Proc.Parameters)
ElseIf Not IsBreak(Token) Then
Fail Token, x.ExpEOS End If
Set Token = ParseAttributes(Proc.Attributes) Set Token = ParseBody(Panel, Proc.Body, LookAhead:=Token) If Not Token.IsKeyword(kwSub) Then Fail Token, x.RuleEndSub, V.Sub
MustEatLineBreak
Dim Name As String = NameBank(Proc.Id.Name)
CheckDupl Panel.Entity, Proc.Id.Name
Panel.Entity.Subs.Add Proc, Name
Set ParseSub = Proc End Function
Private Function ParseFunction(ByVal Access As Accessibility, ByVal Panel As ControlPanel) As FunctionConstruct 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, x.RuleFuncHeader, x.IdName
Set Func.Id = NewId(Token) Dim Name As String = NameBank(Func.Id.Name)
Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Panel, skFunction, Func.Parameters)
ElseIf Not IsBreak(Token) Then
Fail Token, x.ExpEOS End If
For Each Parm In Func.Parameters If StrComp(Name, NameBank(Parm.Id.Name), vbTextCompare) = 0 Then Fail Parm.Id.Name, x.Duplicated Next
If Token.IsKeyword(kwAs) Then Set Token = NextToken If Not IsProperDataType(Token) Then Fail Token, x.AsPrjId, x.PrjOrId Set Func.DataType = NewDataType(Token)
Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Not IsProperId(Token) Then Fail Token, x.AsPrjId, x.IdName
Set Func.DataType.Id.Name = Token Set Token = NextToken End If
ElseIf Func.Id.Name.Suffix <> vbNullChar Then Set Func.DataType = FromChar(Func.Id.Name.Suffix)
Else Set Func.DataType = Panel.Entity.DefTypes(Name) End If
If Token.Kind = tkLeftParenthesis Then Set Token = NextToken If Token.Kind <> tkRightParenthesis Then Fail Token, x.ParensMismatch
Func.DataType.IsArray = True End If
If Not IsBreak(Token) Then MustEatLineBreak Set Token = ParseAttributes(Func.Attributes) Set Token = ParseBody(Panel, Func.Body, LookAhead:=Token) If Not Token.IsKeyword(kwFunction) Then Fail Token, x.RuleEndFunc, V.Function
MustEatLineBreak
CheckDupl Panel.Entity, Func.Id.Name
Panel.Entity.Functions.Add Func, Name
Set ParseFunction = Func End Function
Private Function ParseProperty(ByVal Access As Accessibility, ByVal Panel As ControlPanel) As PropertyConstruct Dim IsNew As Boolean Dim Idx As Integer 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, x.ExpGLSet
Select Case Token.Code Case kwGet
Kind = VbGet
Case kwLet
Kind = VbLet
Case kwSet
Kind = VbSet
Case Else
Fail Token, x.RulePropHeader, x.GLSet End Select
Set Token = NextToken If Not IsProperId(Token, CanHaveSuffix:=Kind = VbGet) Then Fail Token, x.RulePropHeader, x.IdName
Set PropToken = Token Dim Name As String = NameBank(Token)
CheckDupl Panel.Entity, Token, JumpProp:=True
If Panel.Entity.Properties.Exists(Name) Then Set Slot = Panel.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( _
Panel, _
Switch(Kind = VbGet, skPropertyGet, Kind = VbLet, skPropertyLet, True, skPropertySet), _
Prop.Parameters _
)
ElseIf Not IsBreak(Token) Then
Fail Token, x.ExpEOS End If
If Kind = VbGet Then For Each Parm In Prop.Parameters If StrComp(Name, NameBank(Parm.Id.Name), vbTextCompare) = 0 Then Fail Parm.Id.Name, x.Duplicated Next
If Token.IsKeyword(kwAs) Then Set Token = NextToken If Not IsProperDataType(Token) Then Fail Token, x.AsPrjId, x.PrjOrId Set Slot.DataType = NewDataType(Token)
Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Not IsProperId(Token) Then Fail Token, x.AsPrjId, x.IdName
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 = Panel.Entity.DefTypes(Name) End If
If Token.Kind = tkLeftParenthesis Then Set Token = NextToken If Token.Kind <> tkRightParenthesis Then Fail Token, x.ParensMismatch
Slot.DataType.IsArray = True End If
ElseIf Prop.Parameters.Count = 0 Then
Fail Slot.Id.Name, x.ArgReqProp End If
If Kind = VbSet Then If IsBuiltinDataType(Prop.Parameters(Prop.Parameters.Count).Id.Name) Then Fail Slot.Id.Name, x.PropMismatch End If
Set Token = ParseAttributes(Prop.Attributes) Set Token = ParseBody(Panel, Prop.Body, LookAhead:=Token) If Not Token.IsId(cxProperty) Then Fail Token, x.RuleEndProp
MustEatLineBreak
If IsNew Then
Panel.Entity.Properties.Add Slot, Name
ElseIf Slot.Exists(Kind) Then
Fail PropToken, x.AmbiguousName & 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, x.PropMismatch If Parm.IsParamArray Then Fail Slot.Id.Name, x.PropMismatch End If
If Slot.Exists(VbGet) And Slot.Exists(VbLet) Then Set LeftParms = Slot(VbGet).Parameters Set RightParms = Slot(VbLet).Parameters If LeftParms.Count + 1 <> RightParms.Count Then Fail Slot.Id.Name, x.PropMismatch
For Idx = 1 To LeftParms.Count If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail LeftParms(Idx).Id.Name, x.Duplicated Next
If Kind = VbGet Then If Slot.DataType.IsArray <> RightParms(RightParms.Count).DataType.IsArray Then _
Fail Slot.Id.Name, x.PropMismatch
If Slot.DataType.Id.Name.Code <> RightParms(RightParms.Count).DataType.Id.Name.Code Then _
Fail Slot.Id.Name, x.PropMismatch End If End If
If Slot.Exists(VbGet) And Slot.Exists(VbSet) Then Set LeftParms = Slot(VbGet).Parameters Set RightParms = Slot(VbSet).Parameters If LeftParms.Count + 1 <> RightParms.Count Then Fail Slot.Id.Name, x.PropMismatch
For Idx = 1 To LeftParms.Count If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail Slot.Id.Name, x.PropMismatch Next End If
If Slot.Exists(VbLet) And Slot.Exists(VbSet) Then Set LeftParms = Slot(VbLet).Parameters Set RightParms = Slot(VbSet).Parameters If LeftParms.Count <> RightParms.Count Then Fail Slot.Id.Name, x.PropMismatch
For Idx = 1 To LeftParms.Count - 1 If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail Slot.Id.Name, x.PropMismatch Next End If
Set ParseProperty = Prop End Function
Private Function ParseAttributes(ByVal Attrs As KeyedList, Optional ByVal Token As Token) As Token Dim Attr As AttributeConstruct Dim Xp As New Expressionist
Do If Token Is Nothing Then Set Token = NextToken If Not Token.IsKeyword(kwAttribute) Then Exit Do
Set Attr = New AttributeConstruct Set Token = NextToken If Not IsProperId(Token) Then Fail Token, x.RuleAttribute, x.ExpVarId Set Attr.Id = NewId(Token)
Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Not IsProperId(Token) Then Fail Token, x.ExpVarId, x.IdName
Set Attr.Id.Name = Token Set Token = NextToken End If
If Not Token.IsOperator(opEq) Then Fail Token, x.ExpVarId, x.ExpEq Set Attr.Value = Xp.GetExpression(Me) Set Token = Xp.LastToken If Attr.Value Is Nothing Then Fail Token, x.ExpVarId, x.ExpExpr
If Not IsBreak(Token) Then Exit Do Set Token = Nothing Loop
Set ParseAttributes = Token End Function
Private Sub ParseDim( _ ByVal Access As Accessibility, _ ByVal Panel As ControlPanel, _ ByVal Vars As KeyedList, _ Optional ByVal InsideProc As Boolean, _ Optional ByVal IsStatic As Boolean, _ Optional ByVal Token As Token _
) Dim WasArray As Boolean Dim Var As Variable Dim Expr As IExpression Dim Subs As SubscriptPair Dim Xp As Expressionist Dim Bin As BinaryExpression
If InsideProc AndAlso (Access = acPublic OrElse Access = acPrivate) Then Fail Token, x.NotInsideMethod If Token Is Nothing Then Set Token = NextToken
Set Xp = New Expressionist
Xp.CanHaveTo = True
Xp.FullMode = True
Do Set Var = New Variable
Var.Access = Access
Var.IsStatic = IsStatic
If Token.IsKeyword(kwWithEvents) Then If Not Panel.Entity.IsClass Then Fail Token, x.ValidInClass If InsideProc Then Fail Token, x.NotInsideMethod
Var.HasWithEvents = True Set Token = NextToken End If
If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, x.RuleDim, x.IdName Set Var.Id.Name = Token
Set Token = NextToken
WasArray = False
If Token.Kind = tkLeftParenthesis Then Do Set Expr = Xp.GetExpression(Me) Set Token = Xp.LastToken
If Not Expr Is Nothing Then Select Case Expr.Kind Case ekLiteral, ekSymbol, ekUnaryExpr Set Subs = New SubscriptPair Set Subs.LowerBound = SynthLower(Panel.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(Panel.Entity) Set Subs.UpperBound = Expr End If
Case Else
Fail Token, x.InvExpr End Select
Var.Subscripts.Add Subs End If
If Token.Kind <> tkListSeparator Then Exit Do Loop
If Token.Kind <> tkRightParenthesis AndAlso Xp.LastToken.Kind <> tkRightParenthesis Then _
Fail Token, x.ParensMismatch
WasArray = True Set Token = NextToken End If
If Token.IsKeyword(kwAs) Then If Var.Id.Name.Suffix <> vbNullChar Then Fail Token, x.IdHasSygil Set Token = NextToken
If Token.IsOperator(opNew) Then
Var.HasNew = True Set Token = NextToken End If
If Not IsProperDataType(Token) Then Fail Token, x.RuleDim, x.DataType Set Var.DataType = NewDataType(Token)
If Var.HasNew AndAlso Var.DataType.Id.Name.Kind = tkKeyword Then Fail Token, x.NoNew
Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken
If Not IsProperDataType(Token) Then Fail Token, x.RuleDim, x.IdName Set Var.DataType.Id.Name = Token
Set Token = NextToken End If
ElseIf Var.Id.Name.Suffix <> vbNullChar Then Set Var.DataType = FromChar(Var.Id.Name.Suffix)
Else Set Var.DataType = Panel.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, x.InvExpr End If
Var.DataType.IsArray = WasArray If Var.HasNew AndAlso Var.DataType.IsArray Then Fail Token, x.NoNew
If Token.IsOperator(opEq) Then Set Var.Init = Xp.GetExpression(Me) Set Token = Xp.LastToken If Var.Init Is Nothing Then Fail Token, x.InvExpr End If
Dim Name As String = NameBank(Var.Id.Name) If Not InsideProc Then CheckDupl Panel.Entity, Var.Id.Name If Vars.Exists(Name) Then Fail Token, x.AmbiguousName & Name
Vars.Add Var, Name
Panel.AddVar Var
If IsBreak(Token) Then Exit Do If Token.Kind <> tkListSeparator Then Fail Token, x.RuleDim, x.Comma Set Token = NextToken Loop End Sub
Private Sub ParseType(ByVal Access As Accessibility, ByVal Panel As ControlPanel) Dim Name As String Dim Token As Token Dim Ent As Entity Dim Var As Variable Dim Typ As TypeConstruct
Set Ent = New Entity Set Typ = New TypeConstruct
Typ.Access = Access
Set Token = NextToken If Not IsProperId(Token) Then Fail Token, x.RuleType, x.IdName
Set Typ.Id = NewId(Token)
MustEatLineBreak Set Token = Nothing 'Force ParseDim to get next token
Do
ParseDim acLocal, Panel, Ent.Vars, Token:=Token Rem Should not have "A As Boolean, B As ... If Ent.Vars.Count > 1 Then Fail Ent.Vars(2).Id.Name, x.ExpEOS
Set Var = Ent.Vars(1) Rem Must have an explicit data type. If Var.DataType.Id.Name.Line = 0 Then Fail Var.DataType.Id.Name, x.RuleTypeMember, V.As
Rem Must not have an initial value If Var.Init IsNot Nothing Then Fail Var.Init, x.ExpEOS
Ent.Vars.Clear
Name = NameBank(Var.Id.Name) If Typ.Members.Exists(Name) Then Fail Var.Id.Name, x.AmbiguousName & 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, x.RuleEndType, V.Type
Name = NameBank(Typ.Id.Name)
CheckDupl Panel.Entity, Var.Id.Name
Panel.Entity.Types.Add Typ, Name End Sub
Private Function ParseBody( _ ByVal Panel As ControlPanel, _ ByVal Body As KeyedList, _ Optional ByVal IsSingleLine As Boolean, _ Optional ByVal LookAhead As Token _
) As Token Dim Token As Token Dim Stmt As IStmt Dim LStmt As LetConstruct Dim SStmt As SetConstruct Dim Xp As Expressionist Dim Label As LabelConstruct Dim LinNum As LineNumberConstruct
Set Xp = New Expressionist
Do If LookAhead Is Nothing Then Set Token = SkipLineBreaks Else Set Token = LookAhead Set LookAhead = Nothing If IsBreak(Token) Then Set Token = SkipLineBreaks End If
If Not IsSingleLine Then Rem Do we have a line number? If Token.Kind = tkIntegerNumber And Left$(Token.Text, 1) <> "-"Then Set LinNum = New LineNumberConstruct Set LinNum.Value = Token
Body.Add LinNum Set Token = NextToken End If
Rem Do we have a label? If Token.Kind = tkIdentifier Then Set LookAhead = NextToken
If LookAhead.Kind = tkSoftLineBreak Then Set Label = New LabelConstruct Set Label.Id = NewId(Token)
Body.Add Label Set LookAhead = Nothing Set Token = NextToken End If End If End If
Select Case Token.Kind Case tkKeyword Select Case Token.Code Case kwCall Set Stmt = Xp.GetStmt(Me) Set LookAhead = Xp.LastToken If Stmt Is Nothing Then Fail Token, x.ExpEqArg If Stmt.Kind <> snCall Then Stop 'TODO: Remove Stop
Body.Add Stmt
Case kwClose Set LookAhead = ParseClose(Body)
Case kwConst Set LookAhead = ParseConsts(acLocal, Panel, Body, InsideProc:=True)
Case kwContinue
ParseContinue Panel, Body
Case kwDebug Rem HACK: GoTo Up
Case kwDim
ParseDim acLocal, Panel, Body, InsideProc:=True
Case kwDo
ParseDo Panel, Body
Case kwEnd Rem Is it a closing End? Set LookAhead = NextToken
Select Case LookAhead.Kind Case tkKeyword Select Case LookAhead.Code Case kwFunction, kwIf, kwSelect, kwSub, kwWhile, kwWith Exit Do End Select
Case tkIdentifier If LookAhead.Code = cxProperty Then Exit Do End Select
Body.Add New EndConstruct
Case kwErase Set LookAhead = ParseErase(Body)
Case kwExit
ParseExit Panel, Body
Case kwFor Set LookAhead = ParseFor(Panel, Body)
Case kwGet
ParseGet Body
Case kwGoSub
ParseGoSub Panel, Body
Case kwGoTo
ParseGoTo Panel, Body
Case kwIf Set LookAhead = ParseIf(Panel, Body)
Case kwInput Set LookAhead = ParseInput(Body)
Case kwLet Set Stmt = Xp.GetStmt(Me) Set LookAhead = Xp.LastToken If Stmt Is Nothing Then Fail Token, x.ExpEqArg If Stmt.Kind <> snLet Then Stop 'TODO: Remove Stop
Body.Add Stmt
Case kwLSet Set LookAhead = ParseLSet(Body)
Case kwOn Set LookAhead = ParseOn(Panel, Body)
Case kwOpen Set LookAhead = ParseOpen(Body)
Case kwPrint Set LookAhead = ParsePrint(Body)
Case kwPut
ParsePut Body
Case kwRaiseEvent Set LookAhead = ParseRaiseEvent(Body)
Case kwReDim
ParseReDim Panel, Body
Case kwResume Set LookAhead = ParseResume(Panel, Body)
Case kwReturn
Body.Add New ReturnConstruct
Case kwRSet Set LookAhead = ParseRSet(Body)
Case kwSeek Set LookAhead = ParseSeek(Body)
Case kwSelect
ParseSelect Panel, Body
Case kwSet Set Stmt = Xp.GetStmt(Me) Set LookAhead = Xp.LastToken If Stmt Is Nothing Then Fail Token, x.ExpEqArg If Stmt.Kind <> snLet Then Stop 'TODO: Remove Stop
Set LStmt = Stmt Set SStmt = New SetConstruct Set SStmt.Name = LStmt.Name Set SStmt.Value = LStmt.Value Set Stmt = SStmt
Body.Add Stmt
Case kwStatic
ParseDim acLocal, Panel, Body, InsideProc:=True, IsStatic:=True
Case kwStop
Body.Add New StopConstruct
Case kwUnlock Set LookAhead = ParseUnlock(Body)
Case kwWhile
ParseWhile Panel, Body
Case cxWidth Set LookAhead = ParseWidth(Body)
Case kwWith
ParseWith Panel, Body
Case kwWrite Set LookAhead = ParseWrite(Body)
Case kwCase, kwElse, kwElseIf, kwLoop, kwNext, kwWend Set LookAhead = Token Exit Do
Case cxName Set LookAhead = ParseName(Body)
Case Else Rem It should not happen Debug.Assert False End Select
Case tkIdentifier Select Case Token.Code Case cxLock Set LookAhead = ParseLock(Body)
Case cxReset
Body.Add New ResetConstruct
Case cxWidth Set LookAhead = ParseWidth(Body)
Case Else
Up:Set Stmt = Xp.GetStmt(Me, Token, LookAhead) Set LookAhead = Xp.LastToken If Stmt Is Nothing Then Fail Token, x.ExpEqArg
Body.Add Stmt End Select
Case tkEscapedIdentifier GoTo Up
Case tkDirective Do Set Token = NextToken Loop Until IsBreak(Token)
Case tkOperator Select Case Token.Code Case opWithBang, opWithDot GoTo Up
Case Else Debug.Assert False End Select
Case tkHardLineBreak Exit Select
Case Else
Fail Token, x.ExpStmt End Select Loop Until IsSingleLine
If LookAhead Is Nothing Then Set ParseBody = NextToken Else Set ParseBody = LookAhead End If End Function
Private Function IsStatement(ByVal Token As Token) As Boolean Select Case Token.Kind Case tkOperator
IsStatement = Token.Code = opWithBang OrElse Token.Code = opWithDot
Case tkIdentifier, tkEscapedIdentifier, tkKeyword
IsStatement = True End Select End Function
Private Function ParseClose(ByVal Body As KeyedList) As Token Dim Token As Token Dim Expr As IExpression Dim Xp As Expressionist Dim Stmt As CloseConstruct
Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt = New CloseConstruct
Do Set Expr = Xp.GetExpression(Me) Set Token = Xp.LastToken If Expr Is Nothing Then Exit Do
Rem TODO: Check expression's type?
Stmt.FileNumbers.Add Expr Loop While Token.Kind = tkListSeparator
Body.Add Stmt Set ParseClose = Token End Function
Private Sub ParseContinue(ByVal Panel As ControlPanel, ByVal Body As KeyedList) Dim Token As Token Dim Stmt As ContinueConstruct
Set Stmt = New ContinueConstruct Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail Token, x.ExpDoEtc
Select Case Token.Code Case kwDo If Panel.DoCount = 0 Then Fail Token, x.ContinueNonDo
Stmt.What = cwDo
Case kwFor If Panel.ForCount = 0 Then Fail Token, x.ContinueNonFor
Stmt.What = cwFor
Case kwWhile If Panel.WhileCount = 0 Then Fail Token, x.ContinueNonWhile
Stmt.What = cwWhile End Select
Body.Add Stmt End Sub
Private Sub ParseDo(ByVal Panel As ControlPanel, ByVal Body As KeyedList) Dim Token As Token Dim Mark As Token Dim Stmt As DoConstruct Dim Xp As Expressionist
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, x.InvExpr
ElseIf Token.IsKeyword(kwUntil) Then
Stmt.DoType = dtDoUntilLoop Set Stmt.Condition = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.Condition Is Nothing Then Fail Mark, x.InvExpr End If
If Not IsBreak(Token) Then Fail Token, x.ExpEOS
Panel.DoCount += 1 Set Token = ParseBody(Panel, Stmt.Body)
Panel.DoCount -= 1 If Not Token.IsKeyword(kwLoop) Then Fail Token, x.ExpLoop
Set Token = NextToken Set Mark = Token
If Stmt.DoType = dtNone Then If Token.IsKeyword(kwWhile) Then
Stmt.DoType = dtDoLoopWhile Set Stmt.Condition = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.Condition Is Nothing Then Fail Mark, x.InvExpr
ElseIf Token.IsKeyword(kwUntil) Then
Stmt.DoType = dtDoUntilLoop Set Stmt.Condition = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.Condition Is Nothing Then Fail Mark, x.InvExpr End If End If
If Not IsBreak(Token) Then Fail Token, x.ExpEOS
Body.Add Stmt End Sub
Private Function ParseErase(ByVal Body As KeyedList) As Token Dim Token As Token Dim Sym As Symbol Dim Stmt As EraseConstruct
Set Stmt = New EraseConstruct
Do Set Token = NextToken If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, x.RuleErase, x.IdName
Set Sym = New Symbol Set Sym.Value = Token
Stmt.Vars.Add Sym
Set Token = NextToken Loop While Token.Kind = tkListSeparator
Body.Add Stmt Set ParseErase = Token End Function
Private Sub ParseExit(ByVal Panel As ControlPanel, ByVal Body As KeyedList) Dim Token As Token Dim Stmt As ExitConstruct
Set Stmt = New ExitConstruct Set Token = NextToken
If Token.IsKeyword(kwDo) Then If Panel.DoCount = 0 Then Fail Token, x.ExitNonDo
Stmt.What = ewDo
ElseIf Token.IsKeyword(kwFor) Then If Panel.ForCount = 0 Then Fail Token, x.ExitNonFor
Stmt.What = ewFor
ElseIf Token.IsKeyword(kwWhile) Then If Panel.WhileCount = 0 Then Fail Token, x.ExitNonWhile
Stmt.What = ewWhile
ElseIf Token.IsKeyword(kwSub) Then If Panel.BodyType <> ewSub Then Fail Token, x.ExitNonSub
Stmt.What = ewSub
ElseIf Token.IsKeyword(kwFunction) Then If Panel.BodyType <> ewFunction Then Fail Token, x.ExitNonFunc
Stmt.What = ewFunction
ElseIf Token.IsId(cxProperty) Then If Panel.BodyType <> ewProperty Then Fail Token, x.ExitNonProp
Stmt.What = ewProperty
ElseIf Token.IsKeyword(kwSelect) Then If Panel.SelectCount = 0 Then Fail Token, x.ExitNonSelect
Stmt.What = ewSelect
Else
Fail Token, x.ExpDoForEtc End If
Body.Add Stmt End Sub
Private Function ParseFor(ByVal Panel As ControlPanel, ByVal Body As KeyedList) As Token Dim Token As Token Dim Mark As Token Dim Lit As Literal Dim Expr As IExpression Dim Stmt As ForConstruct Dim Xp As Expressionist Dim Bin As BinaryExpression
Set Xp = New Expressionist
Xp.FullMode = True
Xp.CanHaveTo = True Set Token = NextToken
If Token.IsKeyword(kwEach) Then
ParseForEach Panel, Body Exit Function End If
Set Stmt = New ForConstruct If Not IsProperId(Token) Then Fail Token, x.RuleFor, x.IdName
Set Stmt.Counter = New Symbol Set Stmt.Counter.Value = Token
Set Token = NextToken If Not Token.IsOperator(opEq) Then Fail Token, x.RuleFor, x.Equal Set Mark = Token
Set Expr = Xp.GetExpression(Me) Set Token = Xp.LastToken
If Expr Is Nothing Then Fail Mark, x.InvExpr If Expr.Kind <> ekBinaryExpr Then Fail Mark, x.InvExpr Set Bin = Expr If Not Bin.Operator.Value.Code = opTo Then Fail Token, x.RuleFor, V.To
Set Stmt.StartValue = Bin.LHS Set Stmt.EndValue = Bin.RHS
If Token.IsId(cxStep) Then Set Mark = Token
Xp.CanHaveTo = False Set Stmt.Increment = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.Increment Is Nothing Then Fail Mark, x.RuleFor, x.Increment Else Set Lit = New Literal Set Lit.Value = New Token
Lit.Value.Kind = tkIntegerNumber
Lit.Value.Text = "1"
Lit.Value.Code = vbInteger Set Stmt.Increment = Lit End If
If Not IsBreak(Token) Then Fail Token, x.ExpEOS
Panel.ForCount += 1 Set Token = ParseBody(Panel, Stmt.Body)
Panel.ForCount -= 1 If Not Token.IsKeyword(kwNext) Then Fail Token, x.ExpNext
Set Token = NextToken
If IsProperId(Token) And Token.Code = Stmt.Counter.Value.Code Then Rem Next token should be a line-break or a comma. Set Token = NextToken
If Token.Kind = tkListSeparator Then Set Token = New Token
Token.Kind = tkKeyword
Token.Code = kwNext
ElseIf IsBreak(Token) Then Rem OK
Else
Fail Token, x.ExpEOS End If
ElseIf IsBreak(Token) Then Rem OK
Else
Fail Token, x.ExpEOS End If
Body.Add Stmt Set ParseFor = Token End Function
Private Sub ParseForEach(ByVal Panel As ControlPanel, 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, x.RuleForEach, x.VariableName
Set Stmt.Element = New Symbol Set Stmt.Element.Value = Token
Set Token = NextToken If Not Token.IsKeyword(kwIn) Then Fail Token, x.RuleForEach, V.In
Set Token = NextToken If Not IsProperId(Token) Then Fail Token, x.RuleForEach, x.GroupName Set Stmt.Group = Xp.GetStmt(Me, Token) If Stmt.Group Is Nothing Then Fail Token, x.RuleForEach, x.GroupName
Set Token = Xp.LastToken If Not IsBreak(Token) Then Fail Token, x.ExpEOS
Panel.ForCount += 1 Set Token = ParseBody(Panel, Stmt.Body)
Panel.ForCount -= 1 If Not Token.IsKeyword(kwNext) Then Fail Token, x.ExpNext
MustEatLineBreak
Body.Add Stmt End Sub
Private Sub ParseGet(ByVal Body As KeyedList) Dim Token As Token Dim Stmt As GetConstruct Dim Xp As Expressionist
Set Stmt = New GetConstruct Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(Me) Set Token = Xp.LastToken
If Stmt.FileNumber Is Nothing Then Fail Token, x.RuleGet, x.HashFileNumber If Token.Kind <> tkListSeparator Then Fail Token, x.RuleGet, x.Comma
Set Stmt.RecNumber = Xp.GetExpression(Me) Set Token = Xp.LastToken Rem RecNumber can be nothing If Token.Kind <> tkListSeparator Then Fail Token, x.RuleGet, x.Comma
Set Token = NextToken If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, x.RuleGet, x.VariableName
Set Stmt.Var = New Symbol Set Stmt.Var.Value = Token
Body.Add Stmt End Sub
Private Sub ParseGoSub(ByVal Panel As ControlPanel, ByVal Body As KeyedList) Dim Token As Token Dim Stmt As GoSubConstruct Dim Label As LabelConstruct Dim LinNum As LineNumberConstruct
Set Stmt = New GoSubConstruct Set Token = NextToken
If IsProperId(Token) Then Set Label = New LabelConstruct Set Label.Id = NewId(Token)
Set Stmt.Target = Label
ElseIf Token.Kind = tkIntegerNumber AndAlso Left$(Token.Text, 1) <> "-"Then Set LinNum = New LineNumberConstruct Set LinNum.Value = Token
Set Stmt.Target = LinNum Else
Fail Token, x.ExpTarget End If
Body.Add Stmt End Sub
Private Sub ParseGoTo(ByVal Panel As ControlPanel, ByVal Body As KeyedList) Dim Token As Token Dim Stmt As GoToConstruct Dim Label As LabelConstruct Dim LinNum As LineNumberConstruct
Set Stmt = New GoToConstruct Set Token = NextToken
Select Case Token.Kind Case tkIdentifier Set Label = New LabelConstruct Set Label.Id = NewId(Token) Set Stmt.Target = Label
Case tkIntegerNumber If Left$(Token.Text, 1) = "-"Then Fail Token, x.ExpTarget Set LinNum = New LineNumberConstruct Set LinNum.Value = Token
Set Stmt.Target = LinNum
Case Else
Fail Token, x.ExpTarget End Select
Body.Add Stmt End Sub
Private Function ParseIf(ByVal Panel As ControlPanel, ByVal Body As KeyedList) As Token Dim Arm As IfArm Dim Token As Token Dim Stmt As IfConstruct Dim Xp As Expressionist
Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt = New IfConstruct
Set Arm = New IfArm Rem If <condition> ? Set Token = NextToken Set Arm.Condition = Xp.GetExpression(Me, Token) Set Token = Xp.LastToken If Arm.Condition Is Nothing Then Fail Token, x.InvExpr
Rem If <condition> Then ? If Not Token.IsKeyword(kwThen) Then Fail Token, x.RuleIf, V.Then
Stmt.Arms.Add Arm Set Token = NextToken
If Token.Kind = tkSoftLineBreak Then Rem If <condition> Then : Do Set Token = NextToken If IsHardBreak(Token) Then Exit Do
Up: If Not IsStatement(Token) Then Fail Token, x.ExpStmt
Rem If <condition> Then : <statement> Set Token = ParseBody(Panel, Arm.Body, IsSingleLine:=True, LookAhead:=Token) Loop While Token.Kind = tkSoftLineBreak
If Token.IsKeyword(kwElse) Then Rem If <condition> Then : <statement> Else Set Token = NextToken
Do If Token.Kind = tkSoftLineBreak Then Set Token = NextToken If Not IsStatement(Token) Then Fail Token, x.ExpStmt
Set Token = ParseBody(Panel, Stmt.ElseBody, IsSingleLine:=True, LookAhead:=Token) Loop While Token.Kind = tkSoftLineBreak End If
If Not IsHardBreak(Token) Then Fail Token, x.ExpEOS
ElseIf IsHardBreak(Token) Then Set Token = ParseBody(Panel, Arm.Body) If Token.Kind <> tkKeyword Then Fail Token, x.ExpElseEtc
Do Select Case Token.Code Case kwElseIf Set Arm = New IfArm Set Arm.Condition = Xp.GetExpression(Me) If Arm.Condition Is Nothing Then Fail Token, x.InvExpr
Set Token = Xp.LastToken If Not Token.IsKeyword(kwThen) Then Fail Token, x.RuleIf, V.Then
Set Token = ParseBody(Panel, Arm.Body)
Stmt.Arms.Add Arm
Case kwElse Set Token = NextToken If Not IsHardBreak(Token) Then Fail Token, x.ExpEOS
Set Token = ParseBody(Panel, Stmt.ElseBody)
If Token.IsKeyword(kwIf) Then Set Token = NextToken Exit Do End If
Fail Token, x.ExpEnd & V.If
Case kwIf Set Token = NextToken Exit Do
Case Else
Fail Token, x.ExpElseEtc End Select Loop
ElseIf IsStatement(Token) Then GoTo Up
Else
Fail Token, x.NonEndIf End If
Body.Add Stmt Set ParseIf = Token End Function
Private Function ParseInput(ByVal Body As KeyedList) As Token Dim Token As Token Dim Sym As Symbol Dim Xp As Expressionist Dim Stmt As InputConstruct
Set Stmt = New InputConstruct Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.FileNumber Is Nothing Then Fail Token, x.RuleInput, x.HashFileNumber If Token.Kind <> tkListSeparator Then Fail Token, x.RuleInput, x.Comma
Do Set Token = NextToken If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, x.RuleInput, x.VariableName
Set Sym = New Symbol Set Sym.Value = NewId(Token)
Stmt.Vars.Add Sym
Set Token = NextToken Loop While Token.Kind = tkListSeparator
Body.Add Stmt Set ParseInput = Token End Function
Private Function ParseLock(ByVal Body As KeyedList) As Token Dim Stmt As LockConstruct Dim Xp As Expressionist
Set Stmt = New LockConstruct Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(Me) If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, x.RuleLock, x.HashFileNumber
If Xp.LastToken.Kind = tkListSeparator Then
Xp.CanHaveTo = True Set Stmt.RecordRange = Xp.GetExpression(Me) If Stmt.RecordRange Is Nothing Then Fail Xp.LastToken, x.RuleLock, x.RecordRange End If
Body.Add Stmt Set ParseLock = Xp.LastToken End Function
Private Function ParseLSet(ByVal Body As KeyedList) As Token Dim ISt As IStmt Dim Asg As LetConstruct Dim Xp As Expressionist Dim Stmt As LSetConstruct
Set Xp = New Expressionist Set Stmt = New LSetConstruct
Set ISt = Xp.GetStmt(Me) If ISt.Kind <> snLet Then Stop 'TODO: Remove Stop
Set Asg = ISt If Asg.Name.Kind <> ekSymbol Then Stop 'TODO: Remove Stop If Asg.Operator.Value.Code <> opEq Then Fail Asg.Operator.Value, x.RuleLSet, x.Equal
Set Stmt.Name = Asg.Name Set Stmt.Value = Asg.Value
Body.Add Stmt End Function
Private Function ParseName(ByVal Body As KeyedList) As Token Dim Xp As Expressionist Dim Stmt As NameConstruct
Set Stmt = New NameConstruct Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.OldPathName = Xp.GetExpression(Me) If Stmt.OldPathName Is Nothing Then Fail Xp.LastToken, x.RuleName, x.OldPathName If Not Xp.LastToken.IsKeyword(kwAs) Then Fail Xp.LastToken, x.RuleName, V.As
Set Stmt.NewPathName = Xp.GetExpression(Me) If Stmt.NewPathName Is Nothing Then Fail Xp.LastToken, x.RuleName, x.NewPathName
Body.Add Stmt Set ParseName = Xp.LastToken End Function
Private Function ParseOn(ByVal Panel As ControlPanel, ByVal Body As KeyedList) As Token Dim Token As Token Dim WentTo As GoToConstruct Dim Label As LabelConstruct Dim ResStmt As ResumeConstruct Dim OnStmt As OnErrorConstruct Dim Xp As New Expressionist Dim Comp As OnComputedConstruct Dim LinNum As LineNumberConstruct
Set Token = NextToken
If Token.IsKeyword(cxError) Then Set OnStmt = New OnErrorConstruct Set Token = NextToken If Token.IsKeyword(kwLocal) Then Set Token = NextToken
If Token.IsKeyword(kwGoTo) Then Set Token = NextToken
Select Case Token.Kind Case tkIntegerNumber If Left$(Token.Text, 1) = "-"Then Fail Token, x.ExpTarget Set WentTo = New GoToConstruct Set LinNum = New LineNumberConstruct Set LinNum.Value = Token Set WentTo.Target = LinNum Set OnStmt.Statement = WentTo
Case tkIdentifier Set WentTo = New GoToConstruct Set Label = New LabelConstruct Set Label.Id = NewId(Token) Set WentTo.Target = Label Set OnStmt.Statement = WentTo
Case Else
Fail Token, x.ExpTarget End Select
ElseIf Token.IsKeyword(kwResume) Then Set Token = NextToken If Not Token.IsKeyword(kwNext) Then Fail Token, x.ExpNext
Set ResStmt = New ResumeConstruct
ResStmt.IsNext = True Set OnStmt.Statement = ResStmt
Else
Fail Token, x.ExpGoToSub End If
Set Token = NextToken
Body.Add OnStmt
Else Set Comp = New OnComputedConstruct
Xp.FullMode = True Set Comp.Value = Xp.GetExpression(Me, Token) Set Token = Xp.LastToken If Comp.Value Is Nothing Then Fail Token, x.InvExpr
If Token.IsKeyword(kwGoTo) Then
Comp.IsGoTo = True
ElseIf Token.IsKeyword(kwGoSub) Then 'Comp.IsGoTo = False
Else
Fail Token, x.ExpGoToSub End If
Do Set Token = NextToken
Select Case Token.Kind Case tkIntegerNumber If Left$(Token.Text, 1) = "-"Then Fail Token, x.ExpTarget Set LinNum = New LineNumberConstruct Set LinNum.Value = Token
Comp.Targets.Add LinNum
Case tkIdentifier Set Label = New LabelConstruct Set Label.Id = NewId(Token)
Comp.Targets.Add Label
Case Else
Fail Token, x.ExpTarget End Select
Set Token = NextToken Loop While Token.Kind = tkListSeparator
Body.Add Comp End If
Set ParseOn = Token End Function
Private Function ParseOpen(ByVal Body As KeyedList) As Token Dim Token As Token Dim Stmt As OpenConstruct Dim Xp As Expressionist
Set Stmt = New OpenConstruct Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.PathName = Xp.GetExpression(Me) If Stmt.PathName Is Nothing Then Fail Xp.LastToken, x.RuleOpen, x.PathName If Not Xp.LastToken.IsKeyword(kwFor) Then Fail Xp.LastToken, x.RuleOpen, V.For
Set Token = NextToken If Token.Kind <> tkKeyword Then Fail Token, x.ExpAppendEtc
Select Case Token.Code Case cxAppend
Stmt.FileMode = fmAppend
Case cxBinary
Stmt.FileMode = fmBinary
Case kwInput
Stmt.FileMode = fmInput
Case cxOutput
Stmt.FileMode = fmOutput
Case cxRandom
Stmt.FileMode = fmRandom
Case Else
Fail Token, x.ExpAppendEtc End Select
Set Token = NextToken
If Token.IsKeyword(cxAccess) Then Set Token = NextToken
If Token.IsKeyword(cxRead) Then
Stmt.FileAccess = faRead Set Token = NextToken End If
If Token.IsKeyword(kwWrite) Then If Stmt.FileAccess = faRead Then Stmt.FileAccess = faReadWrite Else Stmt.FileAccess = faWrite Set Token = NextToken End If
If Stmt.FileAccess = faNone Then Fail Token, x.ExpReadWrite End If
If Token.IsKeyword(cxShared) Then
Stmt.FileLock = flShared Set Token = NextToken
ElseIf Token.IsKeyword(cxRead) Then
Stmt.FileLock = flRead Set Token = NextToken
If Token.IsKeyword(kwWrite) Then
Stmt.FileAccess = faReadWrite Set Token = NextToken End If
ElseIf Token.IsKeyword(kwWrite) Then
Stmt.FileAccess = faWrite Set Token = NextToken End If
If Not Token.IsKeyword(kwAs) Then Fail Token, x.RuleOpen, V.As Set Stmt.FileNumber = Xp.GetExpression(Me) If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, x.RuleOpen, x.HashFileNumber Set Token = Xp.LastToken
If Token.IsKeyword(cxLen) Then Set Token = NextToken If Not Token.IsOperator(opEq) Then Fail Token, x.RuleOpen, x.Equal
Set Stmt.Length = Xp.GetExpression(Me) Set Token = Xp.LastToken End If
Body.Add Stmt Set ParseOpen = Token End Function
Private Function ParsePrint(ByVal Body As KeyedList) As Token Dim Token As Token Dim Sym As Symbol Dim Arg As PrintArg Dim Expr As IExpression Dim Xp As Expressionist Dim Exec As CallConstruct Dim Stmt As PrintConstruct
Set Stmt = New PrintConstruct Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.FileNumber Is Nothing Then Fail Token, x.RulePrint, x.HashFileNumber If Token.Kind <> tkListSeparator Then Fail Token, x.RulePrint, x.Comma Set Token = Nothing
Do Set Expr = Xp.GetExpression(Me, Token) Set Token = Xp.LastToken If Expr Is Nothing Then Fail Xp.LastToken, x.RulePrint, x.VariableName
Set Arg = New PrintArg
If Expr.Kind = ekIndexer Then Set Exec = Expr
If Exec.LHS.Kind = ekSymbol Then Set Sym = Exec.LHS
If Sym.Value.IsId(cxSpc) Then If Exec.Arguments.Count <> 1 Then Stop 'TODO: Remove Stop Set Arg.Indent = New PrintIndent Set Arg.Indent.Value = Exec.Arguments(1) Set Expr = Xp.GetExpression(Me, Token) Set Token = Xp.LastToken
ElseIf Sym.Value.IsId(cxTab) Then If Exec.Arguments.Count > 1 Then Stop 'TODO: Remove Stop Set Arg.Indent = New PrintIndent
Arg.Indent.IsTab = True Set Arg.Indent.Value = Exec.Arguments(1) Set Expr = Xp.GetExpression(Me, Token) Set Token = Xp.LastToken End If End If
ElseIf Expr.Kind = ekSymbol Then Set Sym = Expr
If Sym.Value.IsId(cxTab) Then Set Arg.Indent = New PrintIndent
Arg.Indent.IsTab = True Set Expr = Xp.GetExpression(Me, Token) Set Token = Xp.LastToken End If End If
Set Arg.Value = Expr
If Token.Kind = tkPrintSeparator Then
Arg.HasSemicolon = True Set Token = NextToken End If
Stmt.Output.Add Arg Loop Until IsEndOfContext(Token)
Body.Add Stmt Set ParsePrint = Token End Function
Private Sub ParsePut(ByVal Body As KeyedList) Dim Token As Token Dim Stmt As PutConstruct Dim Xp As Expressionist
Set Stmt = New PutConstruct Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(Me) Set Token = Xp.LastToken
If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, x.RulePut, x.HashFileNumber If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, x.RulePut, x.Comma
Set Stmt.RecNumber = Xp.GetExpression(Me) Set Token = Xp.LastToken Rem RecNumber can be nothing If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, x.RulePut, x.Comma
Set Token = NextToken If Not IsProperId(Token, CanHaveSuffix:=True) Then Fail Token, x.RulePut, x.IdName
Set Stmt.Var = New Symbol Set Stmt.Var.Value = Token
Body.Add Stmt End Sub
Private Function ParseRaiseEvent(ByVal Body As KeyedList) As Token Dim Token As Token Dim ISt As IStmt Dim Sym As Symbol Dim Xp As Expressionist Dim Exec As CallConstruct Dim Stmt As RaiseEventConstruct
Set Stmt = New RaiseEventConstruct Set Xp = New Expressionist
Xp.FullMode = True
Set ISt = Xp.GetStmt(Me) Set Token = Xp.LastToken If ISt.Kind <> snCall Then Stop 'TODO: Remove Stop
Set Exec = ISt If Exec.LHS.Kind <> ekSymbol Then Stop 'TODO: Remove Stop
Set Sym = Exec.LHS Set Stmt.Id = NewId(Sym.Value) Set Stmt.Arguments = Exec.Arguments
Body.Add Stmt Set ParseRaiseEvent = Token End Function
Private Sub ParseReDim(ByVal Panel As ControlPanel, ByVal Body As KeyedList) Dim Token As Token Dim Var As Variable Dim Stmt As ReDimConstruct
Set Stmt = New ReDimConstruct Set Token = NextToken
If Token.IsKeyword(kwPreserve) Then
Stmt.HasPreserve = True Set Token = NextToken End If
For Each Var In Stmt.Vars If Var.HasNew Then Fail Var.Id.Name, x.NoNew If Var.Init IsNot Nothing Then Stop 'TODO: Remove Stop If Var.Subscripts.Count = 0 Then Fail Var.Id.Name, x.ExpSubscript Next
Body.Add Stmt End Sub
Private Function ParseResume(ByVal Panel As ControlPanel, ByVal Body As KeyedList) As Token Dim Token As Token Dim Label As LabelConstruct Dim Stmt As ResumeConstruct Dim LinNum As LineNumberConstruct
Set Stmt = New ResumeConstruct Set Token = NextToken
Select Case Token.Kind Case tkIntegerNumber If Left$(Token.Text, 1) = "-"Then Fail Token, x.InvLinNum Set LinNum = New LineNumberConstruct Set LinNum.Value = Token Set Stmt.Target = LinNum Set Token = NextToken
Case tkIdentifier Set Label = New LabelConstruct Set Label.Id = NewId(Token) Set Stmt.Target = Label Set Token = NextToken
Case tkKeyword If Token.Code <> kwNext Then Fail Token, x.ExpNext
Stmt.IsNext = True Set Token = NextToken
Case Else Set LinNum = New LineNumberConstruct Set LinNum.Value = New Token
LinNum.Value.Kind = tkIntegerNumber
LinNum.Value.Text = "0"
LinNum.Value.Code = vbInteger Set Stmt.Target = LinNum End Select
Body.Add Stmt Set ParseResume = Token End Function
Private Sub ParseSelect(ByVal Panel As ControlPanel, ByVal Body As KeyedList) Dim Token As Token Dim Expr As IExpression Dim Xp As Expressionist Dim Cs As CaseConstruct Dim Stmt As SelectConstruct Dim IsExpr As BinaryExpression
Set Xp = New Expressionist
Xp.FullMode = True Set Stmt = New SelectConstruct
Set Token = NextToken If Not Token.IsKeyword(kwCase) Then Fail Token, x.RuleSelect, V.Case
Set Stmt.Value = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.Value Is Nothing Then Fail Token, x.InvExpr If Not IsBreak(Token) Then Fail Token, x.ExpEOS
Panel.SelectCount += 1
Rem From now on we'll accept the "To" operator
Xp.CanHaveTo = True
Do Rem We can have a "look-ahead" token Case from ParseBody below. Rem After parsing the statement block it may have stumbled upon "Case Else", for instance. If Not Token.IsKeyword(kwCase) Then Set Token = SkipLineBreaks
Rem We will have this situation if there's an empty Select Case like: Rem Select Case Abc Rem End Select If Token.IsKeyword(kwEnd) Then Set Token = NextToken If Token.IsKeyword(kwSelect) Then Exit Do
Fail Token, x.ExpEnd & V.Select End If
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, x.ExpCompOp
Set IsExpr.Operator = NewOperator(Token) If IsExpr.Operator.IsUnary Then Fail Token, x.ExpCompOp
Set IsExpr.RHS = Xp.GetExpression(Me) Set Token = Xp.LastToken If IsExpr.RHS Is Nothing Then Fail Token, x.InvExpr
Set Expr = IsExpr
ElseIf Token.IsKeyword(kwElse) Then Rem We have a "Case Else". Set Token = ParseBody(Panel, Stmt.CaseElse) If Not Token.IsKeyword(kwSelect) Then Fail Token, x.ExpEnd & V.Select
Rem Cs must not be added after Loop Set Cs = Nothing Exit Do
Else
Fail Token, x.ExpIsElse End If End If
Cs.Conditions.Add Expr
If IsBreak(Token) Then Set Token = ParseBody(Panel, Cs.Body) Exit Do End If
If Token.Kind <> tkListSeparator Then Fail Token, x.CommaOrEOS Loop
If Cs IsNot Nothing Then Stmt.Cases.Add Cs Loop Until Token.IsKeyword(kwSelect)
Panel.SelectCount -= 1
Body.Add Stmt End Sub
Private Function ParseRSet(ByVal Body As KeyedList) As Token Dim ISt As IStmt Dim Asg As LetConstruct Dim Xp As Expressionist Dim Stmt As RSetConstruct
Set Xp = New Expressionist Set Stmt = New RSetConstruct
Set ISt = Xp.GetStmt(Me) If ISt.Kind <> snLet Then Stop 'TODO: Remove Stop
Set Asg = ISt If Asg.Name.Kind <> ekSymbol Then Stop 'TODO: Remove Stop If Asg.Operator.Value.Code <> opEq Then Fail Asg.Operator.Value, x.RuleRSet, x.Equal
Set Stmt.Name = Asg.Name Set Stmt.Value = Asg.Value
Body.Add Stmt End Function
Private Function ParseSeek(ByVal Body As KeyedList) As Token Dim Xp As Expressionist Dim Stmt As SeekConstruct
Set Stmt = New SeekConstruct Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(Me) If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, x.RuleSeek, x.HashFileNumber If Xp.LastToken.Kind <> tkListSeparator Then Fail Xp.LastToken, x.RuleSeek, x.Comma
Set Stmt.Position = Xp.GetExpression(Me) If Stmt.Position Is Nothing Then Fail Xp.LastToken, x.PositionName
Body.Add Stmt Set ParseSeek = Xp.LastToken End Function
Private Function ParseUnlock(ByVal Body As KeyedList) As Token Dim Stmt As UnlockConstruct Dim Xp As Expressionist
Set Stmt = New UnlockConstruct Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(Me) If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, x.RuleUnlock, x.HashFileNumber
If Xp.LastToken.Kind = tkListSeparator Then
Xp.CanHaveTo = True Set Stmt.RecordRange = Xp.GetExpression(Me) If Stmt.RecordRange Is Nothing Then Fail Xp.LastToken, x.RuleUnlock, x.RecordRange End If
Body.Add Stmt Set ParseUnlock = Xp.LastToken End Function
Private Sub ParseWhile(ByVal Panel As ControlPanel, ByVal Body As KeyedList) Dim Token As Token Dim Xp As Expressionist Dim Stmt As WhileConstruct
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, x.InvExpr
If Not IsBreak(Token) Then Fail Token, x.ExpEOS
Panel.WhileCount += 1 Set Token = ParseBody(Panel, Stmt.Body)
Panel.WhileCount -= 1
If Token.IsKeyword(kwWend) Then Rem OK
ElseIf Token.IsKeyword(kwWhile) Then Rem OK
Else
Fail Token, x.ExpWend End If
MustEatLineBreak
Body.Add Stmt End Sub
Private Function ParseWidth(ByVal Body As KeyedList) As Token Dim Stmt As WidthConstruct Dim Xp As Expressionist
Set Stmt = New WidthConstruct Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(Me) If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, x.RuleWidth, x.HashFileNumber If Xp.LastToken.Kind <> tkListSeparator Then Fail Xp.LastToken, x.RuleWidth, x.Comma
Xp.CanHaveTo = True Set Stmt.Value = Xp.GetExpression(Me) If Stmt.Value Is Nothing Then Fail Xp.LastToken, x.RuleWidth, x.WidthName
Body.Add Stmt Set ParseWidth = Xp.LastToken End Function
Private Sub ParseWith(ByVal Panel As ControlPanel, ByVal Body As KeyedList) Dim Token As Token Dim Stmt As WithConstruct Dim Xp As Expressionist
Set Xp = New Expressionist
Xp.FullMode = True Set Stmt = New WithConstruct
Set Token = NextToken If Not IsProperId(Token) Then Fail Token, x.RuleWith, x.ObjectName
Set Stmt.PinObject = Xp.GetStmt(Me, Token) Set Token = Xp.LastToken If Stmt.PinObject Is Nothing Then Fail Token, x.RuleWith, x.ObjectName
Set Token = ParseBody(Panel, Stmt.Body, LookAhead:=Token) If Not Token.IsKeyword(kwWith) Then Fail Token, x.ExpEnd & V.With
Body.Add Stmt End Sub
Private Function ParseWrite(ByVal Body As KeyedList) As Token Dim Token As Token Dim Expr As IExpression Dim Xp As Expressionist Dim Stmt As WriteConstruct
Set Stmt = New WriteConstruct Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(Me) Set Token = Xp.LastToken If Stmt.FileNumber Is Nothing Then Fail Xp.LastToken, x.RuleWrite, x.HashFileNumber If Token.Kind <> tkListSeparator Then Fail Xp.LastToken, x.RuleWrite, x.Comma
Do Set Expr = Xp.GetExpression(Me) Set Token = Xp.LastToken If Expr Is Nothing Then Exit Do
Stmt.Output.Add Expr Loop While Token.Kind = tkListSeparator
Body.Add Stmt Set ParseWrite = Token End Function
Private Function AreEqual(ByVal LeftParm As Parameter, ByVal RightParm As Parameter) As Boolean
AreEqual = LeftParm.IsArray = RightParm.IsArray AndAlso _
LeftParm.IsByVal = RightParm.IsByVal AndAlso _
LeftParm.IsOptional = RightParm.IsOptional AndAlso _
LeftParm.IsParamArray = RightParm.IsParamArray AndAlso _
LeftParm.DataType.Id.Name.Code = RightParm.DataType.Id.Name.Code End Function
Private Function SynthLower(ByVal Entity As Entity) As IExpression Dim Token As Token Dim Lit As Literal
Set Token = New Token
Token.Kind = tkIntegerNumber
Token.Text = CStr(Entity.OptionBase)
Token.Code = vbInteger
Set Lit = New Literal Set Lit.Value = Token Set SynthLower = Lit End Function
Private Sub MustEatLineBreak() Dim Token As Token
Set Token = NextToken If IsBreak(Token) OrElse Token.Kind = tkComment Then Exit Sub
Fail Token, x.ExpEOS End Sub
Private Function SkipLineBreaks() As Token Dim Token As Token
Do Set Token = NextToken Loop While Token.Kind = tkSoftLineBreak OrElse Token.Kind = tkHardLineBreak OrElse Token.Kind = tkComment
Set SkipLineBreaks = Token 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 Pos As Integer Dim Cp As Integer
If Not CanHaveSuffix AndAlso Token.Suffix <> vbNullChar Then Fail Token, x.NoSygil
If Token.Kind = tkIdentifier Then
IsProperId = True Exit Function End If
If Token.Kind <> tkEscapedIdentifier Then Exit Function Dim Text As String = NameBank(Token)
For Pos = 1 To Len(Text)
Cp = AscW(Mid$(Text, Pos, 1)) If Cp <> ASCII_US OrElse _
Cp < ASCII_ZERO OrElse Cp > ASCII_NINE OrElse _ Not IsLetter(Cp) OrElse _ Not IsSurrogate(Cp) Then Exit Function Next
IsProperId = True End Function
Friend Function IsHardBreak(ByVal Token As Token) As Boolean
IsHardBreak = Token.Kind = tkHardLineBreak OrElse Token.Kind = tkComment End Function
Friend Function IsBreak(ByVal Token As Token) As Boolean Select Case Token.Kind Case tkSoftLineBreak, tkHardLineBreak, tkComment, tkEndOfStream
IsBreak = True End Select End Function
Private Function IsProperDataType(ByVal Token As Token) As Boolean If Token.Suffix <> vbNullChar Then Fail Token, x.NoSygil
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, x.NoSygil
If Token.IsKeyword(kwAny) Then
IsDataType = True Exit Function End If
IsDataType = IsProperDataType(Token) End Function
Private Function IsEndOfContext(ByVal Token As Token) As Boolean Dim Result As Boolean
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 = NameBank(Token)
With Entity If .Consts.Exists(Name) OrElse _
.Enums.Exists(Name) OrElse _
.Declares.Exists(Name) OrElse _
.Events.Exists(Name) OrElse _
.Impls.Exists(Name) OrElse _
.Vars.Exists(Name) OrElse _
.Types.Exists(Name) OrElse _
.Subs.Exists(Name) OrElse _
.Functions.Exists(Name) OrElse _ Not JumpProp AndAlso .Properties.Exists(Name) Then _
Fail Token, x.AmbiguousName & Name End With End Sub End Class
Public Class PrintArg Option Explicit
Public Indent As PrintIndent Public Value As IExpression Public HasSemicolon As Boolean End Class
Public Class PrintConstruct Option Explicit Implements IStmt
Private Output_ As KeyedList
Public FileNumber As IExpression
Private Sub Class_Initialize() Set Output_ = New KeyedList Set Output_.T = NewValidator(TypeName(New PrintArg)) End Sub
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snPrint End Property
Public Property Get Output() As KeyedList Set Output = Output_ End Property End Class
Public Class PrintIndent Option Explicit
Public IsTab As Boolean Public Value As IExpression End Class
Public Class PropertyConstruct Option Explicit
Private Parms_ As KeyedList Private Body_ As KeyedList Private Attributes_ 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
Set Attributes_ = New KeyedList Set Attributes_.T = NewValidator(TypeName(New AttributeConstruct)) End Sub
Public Property Get Parameters() As KeyedList Set Parameters = Parms_ End Property
Public Property Get Body() As KeyedList Set Body = Body_ End Property
Public Property Get Attributes() As KeyedList Set Attributes = Attributes_ End Property 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 PropertyGet_ IsNot Nothing Then Err.Raise 457 Set PropertyGet_ = Item
Case VbLet If PropertyLet_ IsNot Nothing Then Err.Raise 457 Set PropertyLet_ = Item
Case VbSet If PropertySet_ IsNot 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
Public FileNumber As IExpression Public RecNumber As IExpression Public Var As Symbol
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snPut End Property End Class
Public Class RaiseEventConstruct Option Explicit Implements IStmt
Private Arguments_ As KeyedList
Public Id As Identifier
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snRaiseEvent End Property
Public Property Get Arguments() As KeyedList Set Arguments = Arguments_ End Property
Friend Property Set Arguments(ByVal Value As KeyedList) Set Arguments_ = Value End Property End Class
Public Class ReDimConstruct Option Explicit Implements IStmt
Private Vars_ As KeyedList
Public HasPreserve As Boolean
Private Sub Class_Initialize() Set Vars_ = New KeyedList Set Vars_.T = NewValidator(TypeName(New Variable)) End Sub
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snReDim End Property
Public Property Get Vars() As KeyedList Set Vars = Vars_ End Property End Class
Public Class ResetConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snReset End Property End Class
Public Class ResumeConstruct Option Explicit Implements IStmt
Public IsNext As Boolean Public Target As IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snResume End Property End Class
Public Class ReturnConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snReturn End Property End Class
Public Class Reverter Option Explicit
Public Builder As ITextBuilder
Public Sub Transpile(ByVal Source As SourceFile) Dim Idx As Integer
For Idx = 1 To Source.Entities.Count
EmitEntity Source.Entities(Idx) 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.OptionBase <> 0 Then
.Append "Option Base "
.AppendLn Entity.OptionBase End If
If Entity.OptionCompare <> vbBinaryCompare Then
.Append "Option Compare "
.AppendLn IIf(Entity.OptionCompare = vbBinaryCompare, "Binary", "Text") End If
If Entity.OptionExplicit Then .AppendLn "Option Explicit"
.AppendLn
EmitAttributes Entity.Attributes
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 += 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 += 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
EmitAttributes Fnc.Attributes
EmitBody Fnc.Body
.Deindent
.AppendLn "End Function"
Count += 1 If Count <> Entity.Functions.Count Then .AppendLn
Sep = True Next
If Sep AndAlso 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
EmitAttributes Prc.Attributes
EmitBody Prc.Body
.Deindent
.AppendLn "End Sub"
Sep = True
Count += 1 If Count <> Entity.Subs.Count Then .AppendLn Next
If Sep AndAlso 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 Mem.Value IsNot 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 Op IsNot 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 += 1 If Count <> Stmt.Arguments.Count Then Builder.Append ", " Next
Builder.Append ")" End If End Sub
Private Sub EmitClose(ByVal Stmt As CloseConstruct) Dim Number As IExpression
Builder.Append "Close"
For Each Number In Stmt.FileNumbers
Builder.Append " "
EmitExpression Number Next End Sub
Private Sub EmitContinue(ByVal Stmt As ContinueConstruct)
Builder.Append "Continue "
Select Case Stmt.What Case cwDo
Builder.Append "Do "
Case cwFor
Builder.Append "For "
Case cwWhile
Builder.Append "While " End Select 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
EmitSubscripts Stmt.Subscripts
Builder.Append " As " If Stmt.HasNew Then Builder.Append "New "
EmitDataType Stmt.DataType
If Stmt.Init IsNot 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) Dim Count As Integer Dim Var As Variable
Builder.Append "Erase "
For Each Var In Stmt.Vars
EmitId Var.Id
Count += 1 If Count <> Stmt.Vars.Count Then Builder.Append ", " Next
Builder.Append " " End Sub
Private Sub EmitExit(ByVal Stmt As ExitConstruct)
Builder.Append "Exit "
Select Case Stmt.What Case ewDo
Builder.Append "Do "
Case ewFor
Builder.Append "For "
Case ewWhile
Builder.Append "While "
Case ewSub
Builder.Append "Sub "
Case ewFunction
Builder.Append "Function "
Case ewProperty
Builder.Append "Property "
Case ewSelect
Builder.Append "Select " End Select 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 OrElse 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)
Builder.Append "Get "
EmitExpression Stmt.FileNumber
Builder.Append ", " If Stmt.RecNumber IsNot Nothing Then EmitExpression Stmt.RecNumber
Builder.Append ", "
EmitToken Stmt.Var.Value End Sub
Private Sub EmitGoSub(ByVal Stmt As GoSubConstruct) Dim Label As LabelConstruct Dim LinNum As LineNumberConstruct
Builder.Append "GoSub "
If Stmt.Target.Kind = snLineNumber Then Set LinNum = Stmt.Target
EmitToken LinNum.Value Else Set Label = Stmt.Target
EmitId Label.Id End If End Sub
Private Sub EmitGoTo(ByVal Stmt As GoToConstruct) Dim Label As LabelConstruct Dim LinNum As LineNumberConstruct
Builder.Append "GoTo "
If Stmt.Target.Kind = snLineNumber Then Set LinNum = Stmt.Target
EmitToken LinNum.Value Else Set Label = Stmt.Target
EmitId Label.Id End If End Sub
Private Sub EmitIf(ByVal Stmt As IfConstruct) Dim Arm As IfArm Dim SubStmt As IStmt Dim Idx As Integer Dim SingleLine As Boolean
If SingleLine Then Set Arm = Stmt.Arms(1)
Builder.Append "If "
EmitExpression Arm.Condition
Builder.Append " Then "
EmitStmt Arm.Body(1)
If Stmt.ElseBody.Count = 1 Then
Builder.Append " Else "
EmitStmt Stmt.ElseBody(1) End If
Else 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 If End Sub
Private Sub EmitInput(ByVal Stmt As InputConstruct) Dim Count As Integer Dim Var As Symbol
For Each Var In Stmt.Vars
EmitToken Var.Value
Count += 1 If Count <> Stmt.Vars.Count Then Builder.Append ", " Next End Sub
Private Sub EmitLabel(ByVal Stmt As LabelConstruct)
Builder.Append NameBank(Stmt.Id.Name)
Builder.Append ": " End Sub
Private Sub EmitLet(ByVal Stmt As LetConstruct)
EmitExpression Stmt.Name
EmitOperator Stmt.Operator
EmitExpression Stmt.Value End Sub
Private Sub EmitLineNumber(ByVal Stmt As LineNumberConstruct)
EmitToken Stmt.Value End Sub
Private Sub EmitLock(ByVal Stmt As LockConstruct)
Builder.Append "Lock "
EmitExpression Stmt.FileNumber
Builder.Append ", "
EmitExpression Stmt.RecordRange End Sub
Private Sub EmitLSet(ByVal Stmt As LSetConstruct)
Builder.Append "LSet "
EmitExpression Stmt.Name
Builder.Append " = "
EmitExpression Stmt.Value End Sub
Private Sub EmitName(ByVal Stmt As NameConstruct)
Builder.Append "Name "
EmitExpression Stmt.OldPathName
Builder.Append " As "
EmitExpression Stmt.NewPathName End Sub
Private Sub EmitOnError(ByVal Stmt As OnErrorConstruct)
Builder.Append "On Error "
If Stmt.Statement.Kind = snGoTo Then
EmitGoTo Stmt.Statement
ElseIf Stmt.Statement.Kind = snResume Then
EmitResume Stmt.Statement End If End Sub
Private Sub EmitOnComputed(ByVal Stmt As OnComputedConstruct) Dim Count As Integer Dim Target As IStmt Dim Label As LabelConstruct
Builder.Append "On "
EmitExpression Stmt.Value
If Stmt.IsGoTo Then
Builder.Append " GoTo " Else
Builder.Append " GoSub " End If
For Each Target In Stmt.Targets If Target.Kind = snLabel Then Set Label = Target
EmitId Label.Id Else
EmitLineNumber Target End If
Count += 1 If Count <> Stmt.Targets.Count Then Builder.Append ", " Next End Sub
Private Sub EmitOpen(ByVal Stmt As OpenConstruct)
Builder.Append "Open "
EmitExpression Stmt.PathName
Builder.Append " For "
Select Case Stmt.FileMode Case fmAppend
Builder.Append "Append"
Case fmBinary
Builder.Append "Binary"
Case fmInput
Builder.Append "Input"
Case fmOutput
Builder.Append "Output"
Case fmRandom
Builder.Append "Random" End Select
If Stmt.FileAccess <> faNone Then
Builder.Append " Access "
Select Case Stmt.FileAccess Case faRead
Builder.Append "Read"
Case faReadWrite
Builder.Append "Read Write"
Case faWrite
Builder.Append "Write" End Select End If
Select Case Stmt.FileLock Case flRead
Builder.Append " Read"
Case flReadWrite
Builder.Append " Read Write"
Case flShared
Builder.Append " Shared"
Case flWrite
Builder.Append " Write" End Select
Builder.Append " As "
EmitExpression Stmt.FileNumber
If Stmt.Length IsNot Nothing Then
Builder.Append " Len="
EmitExpression Stmt.Length End If End Sub
Private Sub EmitPrint(ByVal Stmt As PrintConstruct) Dim Count As Integer Dim Arg As PrintArg
If Arg.Indent IsNot Nothing Then
Builder.Append IIf(Arg.Indent.IsTab, " Tab", " Spc")
If Arg.Indent.Value IsNot Nothing Then
Builder.Append "("
EmitExpression Arg.Indent.Value
Builder.Append ")" End If
Builder.Append " " End If
EmitExpression Arg.Value
If Arg.HasSemicolon Then
Builder.Append ";"
ElseIf Count <> Stmt.Output.Count Then
Builder.Append " " End If Next End Sub
Private Sub EmitPut(ByVal Stmt As PutConstruct)
Builder.Append "Put "
EmitExpression Stmt.FileNumber
Builder.Append ", " If Stmt.RecNumber IsNot Nothing Then EmitExpression Stmt.RecNumber
Builder.Append ", "
EmitToken Stmt.Var.Value End Sub
Private Sub EmitRaiseEvent(ByVal Stmt As RaiseEventConstruct) Dim Count As Integer Dim Expr As IExpression
Builder.Append "RaiseEvent "
EmitId Stmt.Id
If Stmt.Arguments.Count > 0 Then
Builder.Append "("
For Each Expr In Stmt.Arguments
EmitExpression Expr
Count += 1 If Count <> Stmt.Arguments.Count Then Builder.Append ", " Next
Builder.Append ")" End If
Builder.Append " " End Sub
Private Sub EmitReDim(ByVal Stmt As ReDimConstruct) Dim Count As Integer Dim Var As Variable
Builder.Append "ReDim " If Stmt.HasPreserve Then Builder.Append "Preserve "
For Each Var In Stmt.Vars
EmitId Var.Id
EmitSubscripts Var.Subscripts
Builder.Append " As "
EmitDataType Var.DataType
Count += 1 If Count <> Stmt.Vars.Count Then Builder.Append ", " Next End Sub
Private Sub EmitReset(ByVal Stmt As ResetConstruct)
Builder.Append "Reset" End Sub
Private Sub EmitResume(ByVal Stmt As ResumeConstruct) Dim Label As LabelConstruct Dim LinNum As LineNumberConstruct
Builder.Append "Resume"
If Stmt.IsNext Then
Builder.Append " Next "
ElseIf Stmt.Target.Kind = snLabel Then
Builder.Append " " Set Label = Stmt.Target
EmitId Label.Id Else Set LinNum = Stmt.Target
If LinNum.Value.Text <> "0"Then
Builder.Append " "
EmitToken LinNum.Value End If End If End Sub
Private Sub EmitReturn(ByVal Stmt As ReturnConstruct)
Builder.Append "Return " End Sub
Private Sub EmitRSet(ByVal Stmt As RSetConstruct)
Builder.Append "RSet "
EmitExpression Stmt.Name
Builder.Append " = "
EmitExpression Stmt.Value End Sub
Private Sub EmitSeek(ByVal Stmt As SeekConstruct)
Builder.Append "Seek "
EmitExpression Stmt.FileNumber
Builder.Append ", "
EmitExpression Stmt.Position 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 += 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)
Builder.Append "Stop " End Sub
Private Sub EmitUnlock(ByVal Stmt As UnlockConstruct)
Builder.Append "Unlock "
EmitExpression Stmt.FileNumber
Builder.Append ", "
EmitExpression Stmt.RecordRange 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)
Builder.Append "Width "
EmitExpression Stmt.FileNumber
Builder.Append ", "
EmitExpression Stmt.Value End Sub
Private Sub EmitWith(ByVal Stmt As WithConstruct)
Builder.Append "With "
EmitExpression Stmt.PinObject
Builder.AppendLn
For Each Expr In Stmt.Output
EmitExpression Expr
Count += 1 If Count <> Stmt.Output.Count Then Builder.Append ", " Next End Sub
Private Sub EmitToken(ByVal Stmt As Token) Select Case Stmt.Kind Case tkBinaryNumber If Left$(Stmt.Text, 1) = "-"Then Builder.Append "-"
Builder.Append "&B"
Builder.Append Mid$(Stmt.Text, 2)
Case tkDateTime
Builder.Append "#"
Builder.Append Stmt.Text
Builder.Append "#"
Case tkEscapedIdentifier
Builder.Append "["
Builder.Append NameBank(Stmt)
Builder.Append "]"
Case tkFileHandle, tkFloatNumber, tkIntegerNumber, tkSciNumber If Left$(Stmt.Text, 1) = "-"Then Builder.Append "-"
Builder.Append Mid$(Stmt.Text, 2)
Case tkHexaNumber If Left$(Stmt.Text, 1) = "-"Then Builder.Append "-"
Builder.Append "&H"
Builder.Append Mid$(Stmt.Text, 2)
Case tkIdentifier, tkKeyword
Builder.Append NameBank(Stmt)
Case tkOperator
Builder.Append Replace(NameBank(Stmt), "~", "")
Case tkOctalNumber If Left$(Stmt.Text, 1) = "-"Then Builder.Append "-"
Builder.Append "&O"
Builder.Append Mid$(Stmt.Text, 2)
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 Exit Select
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
Public Name As IExpression Public Value As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snRSet End Property End Class
Public Class Scanner Option Explicit
Private Const Msg_ = "Invalid literal"
Private Const LF_ As Integer = 10 'Line feed Private Const CR_ As Integer = 13 'Carriage return Private Const SP_ As Integer = 32 'Space Private Const US_ As Integer = 95 'Underscore Private Const BS_ As Integer = 8 'Backspace. Used for line continuation Private Const 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
Private Sub Class_Initialize()
RunningLine_ = 0
RunningColumn_ = 1 End Sub
Private Function AtEnd() As Boolean
AtEnd = Seek(File_) > LOF(File_) End Function
Public Sub OpenFile(ByVal FilePath As String)
FilePath_ = FilePath If Dir(FilePath) = ""Then Err.Raise 53
File_ = FreeFile Open FilePath For Binary Access Read Write As #File_
Rem If the error below happens, we'll let a new-ly created zero-length file behind. If LOF(File_) = 0 Then Err.Raise 53
Dim Cp As Integer = GetCodePoint If Cp <> &HFEFF Then UngetChar ChrW$(Cp) End Sub
Public Function GetToken() As Token Dim Done As Boolean Dim Cp As Integer Dim Ch As String * 1 Dim Token As Token
If AtEnd Then Set GetToken = NewToken(tkEndOfStream) Exit Function End If
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) Debug.Assert Token.Text <> ""
Rem Removing leading zeros in excess Do While Left$(Token.Text, 1) = "0"
Token.Text = Mid$(Token.Text, 2) Loop
Select Case Left$(Token.Text, 1) Case"", "."
Token.Text = "0" & Token.Text End Select
If Token.Code = 0 Then Select Case Token.Kind Case tkIntegerNumber Select Case Right$(String$(18, "0") & Token.Text, 19) Case Is <= "0000000000000032767"
Token.Code = vbInteger
Case Is <= "0000000002147483647"
Token.Code = vbLong
Case Is <= CStr(9_223_372_036_854_775_807)
Token.Code = vbLongLong
Case Else
Token.Code = vbDouble End Select
Case tkBinaryNumber Select Case Len(Token.Text) Case Is > 64
Token.Code = vbDouble
Case Is > 32
Token.Code = vbLongLong
Case Is > 16
Token.Code = vbLong
Case Else
Token.Code = vbInteger End Select
Case tkOctalNumber Select Case Right$(String(21, "0") & Token.Text, 19) Case Is <= "000000000000000077777"
Token.Code = vbInteger
Case Is <= "000000000017777777777"
Token.Code = vbLong
Case Is <= "177777777777777777777"
Token.Code = vbLongLong
Case Else
Token.Code = vbDouble End Select
Case tkHexaNumber Select Case Len(Token.Text) Case Is > 16
Token.Code = vbDouble
Case Is > 8
Token.Code = vbLongLong
Case Is > 4
Token.Code = vbLong
Case Else
Token.Code = vbInteger End Select
Case tkFloatNumber, tkSciNumber
Token.Code = vbDouble
Case Else Debug.Assert False End Select End If
Token.Text = "+" & Token.Text
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_ += 1
NextCodePoint = Result End Function
Private Function GetChar() As String Dim Cp As Integer = 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 >> 8
ToChar = Bytes End Function
Private Sub AdvanceLine()
RunningLine_ += 1
PreviousColumn_ = RunningColumn_
RunningColumn_ = 1 End Sub
Private Sub UngetChar(ByVal Character As String) Dim Length As Long = SizeOf(kwInteger) If Character = vbBack Then Length = Length * 2 + Len(vbNewLine) * SizeOf(kwInteger) Dim Pos As Long = Seek(File_) Seek #File_, Pos - Length
Select Case Character Case vbLf, vbBack
RunningLine_ -= 1
RunningColumn_ = PreviousColumn_ End Select
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 Suffix As String * 1 Dim Buffer As String * MAX_LENGTH Dim Result As Token
Dim Count As Integer = 1
Mid$(Buffer, Count, 1) = ChrW(CodePoint)
Do Until AtEnd Dim Cp As Integer = GetCodePoint Dim Ch As String * 1 = ToChar(Cp)
If Ch <> "_"AndAlso _
(Ch < "0"OrElse Ch > "9") AndAlso _ Not IsLetter(Cp) AndAlso _ Not IsSurrogate(Cp) Then _ Exit Do
Count += 1 If Count > MAX_LENGTH Then Fail "Identifier too long"
Mid$(Buffer, Count, 1) = Ch Loop
Set Result = NewToken(tkIdentifier, Suffix:=Suffix) Dim Name As String = Left$(Buffer, Count) Dim Index As Long = 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 += 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 AndAlso Result.Suffix = "$"Then
Result.Kind = tkIdentifier
Index = NameBank.Ids.IndexOf(V.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 Count As Integer Dim Suffix As String * 1 Dim Buffer As String * MAX_LENGTH Dim Token As Token
Do Until AtEnd Dim Cp As Integer = GetCodePoint If Cp = AscW("]") Then Exit Do If Cp = LF_ Then Fail "Invalid identifier"
Count += 1 If Count > MAX_LENGTH Then Fail "Identifier too long"
Mid$(Buffer, Count, 1) = ToChar(Cp) Loop
Case Else
UngetChar Suffix
Suffix = vbNullChar End Select End If
Set Token = NewToken(tkEscapedIdentifier, Suffix:=Suffix) Dim Name As String = Left$(Buffer, Count)
Token.Code = NameBank.Ids.IndexOf(Name)
If Token.Code = 0 Then
NameBank.Ids.Add Name, Name
Token.Code = NameBank.Ids.Count End If
Token.Code = Token.Code + NameBank.Keywords.Count + NameBank.Contextuals.Count 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 += 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 Count As Integer Dim Ch As String * 1 Dim Suffix As String * 1 Dim Buffer As String * MAX_LENGTH
If FirstDigit >= "0"AndAlso FirstDigit <= "9"Then
Count = 1
Mid$(Buffer, Count, 1) = FirstDigit End If
Do Until AtEnd If Count = MAX_LENGTH Then Fail "Literal too long" Dim Cp As Integer = GetCodePoint
Ch = ToChar(Cp)
Set ReadInteger = NewToken(tkIntegerNumber, , Left$(Buffer, Count), Suffix) End Function
Private Function ReadFloat(ByVal FirstDigit As String) As Token Dim Result As Token Dim FracPart As Token
Set Result = ReadInteger(FirstDigit:=FirstDigit)
If Result.Suffix = vbNullChar AndAlso Not AtEnd Then Dim Ch As String * 1 = GetChar
If Ch = "."Then Set FracPart = ReadInteger If FracPart.Text = ""Then Fail "Invalid literal"
Result.Text &= "." & FracPart.Text
Result.Kind = tkFloatNumber
Result.Suffix = FracPart.Suffix Else
UngetChar Ch End If End If
Set ReadFloat = Result End Function
Private Function ReadNumber(ByVal FirstDigit As String) As Token Dim Result As Token Dim ExpPart As Token
Set Result = ReadFloat(FirstDigit)
If Result.Suffix = vbNullChar AndAlso Not AtEnd Then Dim Ch As String * 1 = GetChar
Select Case Ch Case"e", "E" If AtEnd Then
UngetChar Ch Else Dim Sg As String * 1 = GetChar
If Sg = "-"OrElse Sg = "+"Then
Ch = "" Else
Ch = Sg
Sg = "+" End If
Set ExpPart = ReadInteger(FirstDigit:=Ch) If ExpPart.Text = ""OrElse ExpPart.Suffix <> vbNullChar Then Fail "Invalid literal"
Result.Text &= "E" & Sg & ExpPart.Text
Result.Kind = tkSciNumber End If
Case Else
UngetChar Ch End Select End If
Result.Text = Result.Text Set ReadNumber = Result End Function
Private Function ReadAmpersand() As Token Dim Token As Token
Dim Ch As String * 1 = GetChar
Select Case Ch Case"b", "B" Set Token = ReadBin
Token.Text = "+" & Token.Text
Case"=" Set Token = NewToken(tkOperator, opCompConcat)
Case Else
UngetChar Ch Set Token = NewToken(tkOperator, opConcat) End Select
Set ReadAmpersand = Token End Function
Private Function ReadBin() As Token Static Chars As KeyedList
If Chars Is Nothing Then Set Chars = New KeyedList
Chars.AddKVPairs "0", "0", "1", "1" End If
Set ReadBin = ReadBOH(Chars, 96, tkBinaryNumber) End Function
Private Function ReadOctal() Static Chars As KeyedList
If Chars Is Nothing Then Set Chars = New KeyedList
Chars.AddKVPairs "0", "0", "1", "1", "2", "2", "3", "3", "4", "4", "5", "5", "6", "6", "7", "7" End If
Set ReadOctal = ReadBOH(Chars, 32, tkOctalNumber) End Function
Private Function ReadHexa() As Token Static Chars As KeyedList
If Chars Is Nothing Then Set Chars = New KeyedList
Chars.AddKVPairs "0", "0", "1", "1", "2", "2", "3", "3", "4", "4", "5", "5", "6", "6", "7", "7", "8", "8", "9", "9", _ "a", "a", "b", "b", "c", "c", "d", "d", "e", "e", "f", "f", _ "A", "A", "B", "B", "C", "C", "D", "D", "E", "E", "F", "F" End If
Set ReadHexa = ReadBOH(Chars, 24, tkHexaNumber) End Function
Private Function ReadHash() As Token Dim Number As Integer Dim Name As String 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$(V.If), UCase$(V.ElseIf), UCase$(V.Else), UCase$(V.End), UCase$(V.Const) 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. Dim Cp As Integer = GetCodePoint Dim Ch As String * 1 = 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 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. Dim Ch As String * 1 = GetChar If Ch <> Separator Then Fail Msg_
Set ThirdNumber = ReadInteger If ThirdNumber.Text = ""Then Fail Msg_
If CInt(FirstNumber) >= 100 AndAlso 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 += 1900 If YYYY < 1950 Then YYYY += 100 End If End If
Rem Validate year. If YYYY > 9999 Then Fail Msg_
Rem Validate month. If MM < 1 OrElse 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 AndAlso YYYY Mod 100 <> 0 OrElse 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 &= "0" If YYYY < 10 Then Result &= "0"
Result &= CStr(YYYY)
Result &= "-"
If MM < 10 Then Result &= "0"
Result &= CStr(MM)
Result &= "-"
If DD < 10 Then Result &= "0"
Result &= CStr(DD)
ReadDate = Result End Function
Private Function ReadTime(Optional ByVal FirstNumber As String) As String Dim SS As Integer Dim Ch2 As String * 1 Dim AP As String * 1
On Error GoTo GoneWrong Dim HH As Integer = CInt(FirstNumber) Dim Number As String = ReadInteger If Number = ""Then Err.Raise 0 Dim NN As Integer = CInt(Number)
Dim Ch As String * 1 = 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"OrElse Ch = "A"Then
Ch2 = GetChar
If Ch2 = "m"OrElse Ch2 = "M"Then
AP = "A" Else
UngetChar Ch2
UngetChar Ch
UngetChar " " End If
ElseIf Ch = "p"OrElse Ch = "P"Then
Ch2 = GetChar
If Ch2 = "m"OrElse 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 OrElse HH > 23 Then Err.Raise 0 If NN < 0 OrElse NN > 59 Then Err.Raise 0 If SS < 0 OrElse 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 += 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
Do Until AtEnd Dim Prv As String * 1 = Ch Dim Ch As String * 1 = 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 &= 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 += 1
If StrComp(Name, MonthName, vbTextCompare) = 0 Then Result = Count If Result = 0 AndAlso StrComp(Name, Left$(MonthName, 3), vbTextCompare) = 0 Then Result = Count If Result <> 0 Then Exit For Next
ConvertNameToNumber = Result End Function
Private Function NewToken( _ ByVal Kind As TokenKind, _ Optional ByVal Code As Long, _ Optional ByVal Text As String, _ Optional ByVal Suffix As String = vbNullChar _
) As Token Set NewToken = New Token
With NewToken
.Text = Text
.Code = Code
.Kind = Kind
.Suffix = Suffix
.Line = RunningLine_
.Column = FrozenColumn_ End With End Function
Private Function ReadComment(Optional ByVal IsRem As Boolean) As Token Const MAX_LENGTH = 1013
Dim Count As Integer Dim Text As String Dim Ch As String * 1 Dim Buffer As String * MAX_LENGTH
If IsRem Then
Text = V.[Rem] & " " Else
Text = " '" End If
Count = Len(Text)
Mid$(Buffer, 1, Count) = Text
Do Until AtEnd If Count = MAX_LENGTH Then Fail "Comment too long"
Ch = GetChar If Ch = vbLf Then Exit Do
Count += 1
Mid$(Buffer, Count, 1) = Ch Loop
Set ReadComment = NewToken(tkComment, Text:=Left$(Buffer, Count)) End Function
Private Sub DiscardComment() Dim Count As Long = 1
Do Until AtEnd Dim Ch As String * 1 = GetChar
Select Case Ch Case"`"
Count += 1
Case"´"
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
Private Function ReadBOH(ByVal AllowedChars As KeyedList, ByVal MaxLength As Integer, ByVal Kind As TokenKind) As Token Dim Count As Integer Dim Ch As String * 1 Dim Suffix As String * 1 Dim Buffer As String * 96
Dim Skip As Boolean = True
Do Until AtEnd If Count = MaxLength Then Fail "Literal too long"
Ch = GetChar
Select Case Ch Case"%", "&", "^", "@", "!", "#"
Suffix = Ch Exit Do
Case"_" Rem We'll ignore it
Case"0" If Not Skip Then GoTo 10
Case Else If Not AllowedChars.Exists(Ch) Then
UngetChar Ch Exit Do End If
If Skip Then
Count = 1
Mid$(Buffer, Count, 1) = "0" End If
If Count = 0 Then Fail "Invalid literal" Set ReadBOH = NewToken(Kind, , Left$(Buffer, Count), Suffix) End Function
End Class
Public Class SeekConstruct Option Explicit Implements IStmt
Public FileNumber As IExpression Public Position As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snSeek End Property End Class
Public Class SelectConstruct Option Explicit Implements IStmt
Private Cases_ As KeyedList Private CaseElse_ As KeyedList
Public Value As IExpression
Private Sub Class_Initialize() Set Cases_ = New KeyedList Set Cases_.T = NewValidator(TypeName(New CaseConstruct))
Set CaseElse_ = New KeyedList Set CaseElse_.T = New StmtValidator End Sub
Public Property Get Cases() As KeyedList Set Cases = Cases_ End Property
Public Property Get CaseElse() As KeyedList Set CaseElse = CaseElse_ End Property
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snSelect End Property End Class
Public Class SetConstruct Option Explicit Implements IStmt
Public Name As IExpression Public Value As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snSet End Property End Class
Public Class SourceFile Option Explicit
Private Entities_ As KeyedList
Public Path As String
Private Sub Class_Initialize() Set Entities_ = New KeyedList Set Entities_.T = NewValidator(TypeName(New Entity))
Entities_.CompareMode = vbTextCompare End Sub
Public Property Get Entities() As KeyedList Set Entities = Entities_ End Property End Class
Public Class StmtValidator Option Explicit Implements IKLValidator
Private Function IKLValidator_Validate(ByVal Item As Variant) As Boolean
IKLValidator_Validate = TypeOf Item Is IStmt End Function End Class
Public Class StopConstruct Option Explicit Implements IStmt
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snStop End Property End Class
Public Class SubConstruct Option Explicit
Private Parms_ As KeyedList Private Body_ As KeyedList Private Attributes_ 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
Set Attributes_ = New KeyedList Set Attributes_.T = NewValidator(TypeName(New AttributeConstruct)) End Sub
Public Property Get Parameters() As KeyedList Set Parameters = Parms_ End Property
Public Property Get Body() As KeyedList Set Body = Body_ End Property
Public Property Get Attributes() As KeyedList Set Attributes = Attributes_ End Property 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
IsKeyword = Kind = tkKeyword AndAlso Me.Code = Code End Function
Public Function IsOperator(ByVal Code As Long) As Boolean
IsOperator = Kind = tkOperator AndAlso Me.Code = Code End Function
Public Function IsId(ByVal Code As Long, Optional ByVal CanHaveSuffix As Boolean) As Boolean If Not CanHaveSuffix And Suffix <> vbNullChar Then Exit Function
Select Case Kind Case tkIdentifier, tkEscapedIdentifier
IsId = Me.Code = Code End Select End Function End Class
Public Class TupleConstruct Option Explicit Implements IExpression
Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekTuple End Property
Public Static Property Get Elements() As KeyedList Dim Hidden As New KeyedList
Set Elements = Hidden End Property End Class
Public Class TypeConstruct Option Explicit
Private Members_ As KeyedList
Public Access As Accessibility Public Id As Identifier
Private Sub Class_Initialize() Set Members_ = New KeyedList Set Members_.T = NewValidator(TypeName(New Variable))
Members_.CompareMode = vbTextCompare End Sub
Public Property Get Members() As KeyedList Set Members = Members_ End Property End Class
Public Class UnaryExpression Option Explicit Implements IExpression
Public Operator As Operator Public Value As IExpression
Private Property Get IExpression_Kind() As ExpressionKind
IExpression_Kind = ekUnaryExpr End Property End Class
Public Class UnlockConstruct Option Explicit Implements IStmt
Public FileNumber As IExpression Public RecordRange As IExpression
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snUnlock End Property End Class
Public Class Variable Option Explicit Implements IStmt
Private Subscripts_ As KeyedList
Public IsStatic As Boolean Public HasWithEvents As Boolean Public HasNew As Boolean Public 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 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 Obj As IEnumVariantType
IncRefCount ParentObj Dim Ptr As LongPtr = HeapAlloc(GetProcessHeap, dwFlags:=0, dwBytes:=Len(Obj))
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 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 Vocabulary Option Explicit
Rem Contextual in VB6 Public Property Get [Access]() As String
[Access] = "Access" End Property
Public Property Get [AddressOf]() As String
[AddressOf] = "AddressOf" End Property
Rem Contextual in VB6 Public Property Get [Alias]() As String
[Alias] = "Alias" End Property
Public Property Get [And]() As String
[And] = "And" End Property
Rem New! Public Property Get [AndAlso]() As String
[AndAlso] = "AndAlso" End Property
Public Property Get [Any]() As String
[Any] = "Any" End Property
Rem Contextual in VB6 Public Property Get [Append]() As String
[Append] = "Append" End Property
Public Property Get [As]() As String
[As] = "As" End Property
Public Property Get [Attribute]() As String
[Attribute] = "Attribute" End Property
Rem Contextual in VB6 Public Property Get [Base]() As String
[Base] = "Base" End Property
Rem Contextual in VB6 Public Property Get [Binary]() As String
[Binary] = "Binary" End Property
Public Property Get [Boolean]() As String
[Boolean] = "Boolean" End Property
Public Property Get [ByRef]() As String
[ByRef] = "ByRef" End Property
Public Property Get [ByVal]() As String
[ByVal] = "ByVal" End Property
Public Property Get [Byte]() As String
[Byte] = "Byte" End Property
Public Property Get [Call]() As String
[Call] = "Call" End Property
Public Property Get [Case]() As String
[Case] = "Case" End Property
Public Property Get [CDecl]() As String
[CDecl] = "CDecl" End Property
Public Property Get [Circle]() As String
[Circle] = "Circle" End Property
Rem New! Public Property Get [Class]() As String
[Class] = "Class" End Property
Public Property Get [Close]() As String
[Close] = "Close" End Property
Rem Contextual in VB6 Public Property Get [Compare]() As String
[Compare] = "Compare" End Property
Public Property Get [Const]() As String
[Const] = "Const" End Property
Rem New! Public Property Get [Continue]() As String
[Continue] = "Continue" End Property
Public Property Get [Currency]() As String
[Currency] = "Currency" End Property
Public Property Get [Date]() As String
[Date] = "Date" End Property
Public Property Get [Decimal]() As String
[Decimal] = "Decimal" End Property
Public Property Get [Debug]() As String
[Debug] = "Debug" End Property
Public Property Get [Declare]() As String
[Declare] = "Declare" End Property
Rem New! Public Property Get [Default]() As String
[Default] = "Default" End Property
Public Property Get [DefBool]() As String
[DefBool] = "DefBool" End Property
Public Property Get [DefByte]() As String
[DefByte] = "DefByte" End Property
Public Property Get [DefCur]() As String
[DefCur] = "DefCur" End Property
Public Property Get [DefDate]() As String
[DefDate] = "DefDate" End Property
Public Property Get [DefDbl]() As String
[DefDbl] = "DefDbl" End Property
Public Property Get [DefDec]() As String
[DefDec] = "DefDec" End Property
Public Property Get [DefInt]() As String
[DefInt] = "DefInt" End Property
Public Property Get [DefLng]() As String
[DefLng] = "DefLng" End Property
Rem New! Public Property Get [DefLngLng]() As String
[DefLngLng] = "DefLngLng" End Property
Rem New! Public Property Get [DefLngPtr]() As String
[DefLngPtr] = "DefLngPtr" End Property
Public Property Get [DefObj]() As String
[DefObj] = "DefObj" End Property
Public Property Get [DefSng]() As String
[DefSng] = "DefSng" End Property
Public Property Get [DefStr]() As String
[DefStr] = "DefStr" End Property
Public Property Get [DefVar]() As String
[DefVar] = "DefVar" End Property
Public Property Get [Dim]() As String
[Dim] = "Dim" End Property
Public Property Get [Do]() As String
[Do] = "Do" End Property
Public Property Get [Double]() As String
[Double] = "Double" End Property
Public Property Get [Each]() As String
[Each] = "Each" End Property
Public Property Get [ElseIf]() As String
[ElseIf] = "ElseIf" End Property
Public Property Get [Else]() As String
[Else] = "Else" End Property
Public Property Get [Empty]() As String
[Empty] = "Empty" End Property
Public Property Get [End]() As String
[End] = "End" End Property
Public Property Get [EndIf]() As String
[EndIf] = "EndIf" End Property
Public Property Get [Enum]() As String
[Enum] = "Enum" End Property
Public Property Get [Eqv]() As String
[Eqv] = "Eqv" End Property
Public Property Get [Erase]() As String
[Erase] = "Erase" End Property
Rem Contextual in VB6 Public Property Get [Error]() As String
[Error] = "Error" End Property
Public Property Get [Event]() As String
[Event] = "Event" End Property
Public Property Get [Exit]() As String
[Exit] = "Exit" End Property
Rem Contextual in VB6 Public Property Get [Explicit]() As String
[Explicit] = "Explicit" End Property
Public Property Get [False]() As String
[False] = "False" End Property
Public Property Get [For]() As String
[For] = "For" End Property
Public Property Get [Friend]() As String
[Friend] = "Friend" End Property
Public Property Get [Function]() As String
[Function] = "Function" End Property
Public Property Get [Get]() As String
[Get] = "Get" End Property
Public Property Get [Global]() As String
[Global] = "Global" End Property
Public Property Get [GoSub]() As String
[GoSub] = "GoSub" End Property
Public Property Get [GoTo]() As String
[GoTo] = "GoTo" End Property
Public Property Get [If]() As String
[If] = "If" End Property
Public Property Get [Imp]() As String
[Imp] = "Imp" End Property
Public Property Get [Implements]() As String
[Implements] = "Implements" End Property
Public Property Get [In]() As String
[In] = "In" End Property
Public Property Get [Input]() As String
[Input] = "Input" End Property
Public Property Get [Integer]() As String
[Integer] = "Integer" End Property
Public Property Get [Is]() As String
[Is] = "Is" End Property
Rem New! Public Property Get [IsNot]() As String
[IsNot] = "IsNot" End Property
Rem New! Public Property Get [Iterator]() As String
[Iterator] = "Iterator" End Property
Public Property Get [Let]() As String
[Let] = "Let" End Property
Rem Contextual in VB6 Public Property Get [Lib]() As String
[Lib] = "Lib" End Property
Public Property Get [Like]() As String
[Like] = "Like" End Property
Rem Contextual in VB6 Public Property Get [Line]() As String
[Line] = "Line" End Property
Public Property Get [Lock]() As String
[Lock] = "Lock" End Property
Public Property Get [Local]() As String
[Local] = "Local" End Property
Public Property Get [Long]() As String
[Long] = "Long" End Property
Rem New! Public Property Get [LongPtr]() As String
[LongPtr] = "LongPtr" End Property
Rem New! Public Property Get [LongLong]() As String
[LongLong] = "LongLong" End Property
Public Property Get [Loop]() As String
[Loop] = "Loop" End Property
Public Property Get [LSet]() As String
[LSet] = "LSet" End Property
Public Property Get [Len]() As String
[Len] = "Len" End Property
Public Property Get [Me]() As String
[Me] = "Me" End Property
Public Property Get [Mod]() As String
[Mod] = "Mod" End Property
Rem Upgraded from contextual keyword (Option Private Module) to keyword Public Property Get [Module]() As String
[Module] = "Module" End Property
Rem Contextual in VB6 Public Property Get [Name]() As String
[Name] = "Name" End Property
Public Property Get [New]() As String
[New] = "New" End Property
Public Property Get [Next]() As String
[Next] = "Next" End Property
Public Property Get [Not]() As String
[Not] = "Not" End Property
Public Property Get [Nothing]() As String
[Nothing] = "Nothing" End Property
Public Property Get [Null]() As String
[Null] = "Null" End Property
Rem Contextual in VB6 Public Property Get [Object]() As String
[Object] = "Object" End Property
Public Property Get [On]() As String
[On] = "On" End Property
Public Property Get [Open]() As String
[Open] = "Open" End Property
Public Property Get [Option]() As String
[Option] = "Option" End Property
Public Property Get [Optional]() As String
[Optional] = "Optional" End Property
Public Property Get [Or]() As String
[Or] = "Or" End Property
Rem New! Public Property Get [OrElse]() As String
[OrElse] = "OrElse" End Property
Rem Contextual in VB6 Public Property Get [Output]() As String
[Output] = "Output" End Property
Public Property Get [ParamArray]() As String
[ParamArray] = "ParamArray" End Property
Public Property Get [PSet]() As String
[PSet] = "PSet" End Property
Public Property Get [Preserve]() As String
[Preserve] = "Preserve" End Property
Public Property Get [Print]() As String
[Print] = "Print" End Property
Public Property Get [Private]() As String
[Private] = "Private" End Property
Public Property Get [Property]() As String
[Property] = "Property" End Property
Rem New! Public Property Get [PtrSafe]() As String
[PtrSafe] = "PtrSafe" End Property
Public Property Get [Public]() As String
[Public] = "Public" End Property
Public Property Get [Put]() As String
[Put] = "Put" End Property
Public Property Get [RaiseEvent]() As String
[RaiseEvent] = "RaiseEvent" End Property
Rem Contextual in VB6 Public Property Get [Random]() As String
[Random] = "Random" End Property
Rem Contextual in VB6 Public Property Get [Read]() As String
[Read] = "Read" End Property
Public Property Get [ReDim]() As String
[ReDim] = "ReDim" End Property
Public Property Get [Rem]() As String
[Rem] = "Rem" End Property
Rem Contextual in VB6 Public Property Get [Reset]() As String
[Reset] = "Reset" End Property
Public Property Get [Resume]() As String
[Resume] = "Resume" End Property
Public Property Get [Return]() As String
[Return] = "Return" End Property
Public Property Get [RSet]() As String
[RSet] = "RSet" End Property
Public Property Get [Seek]() As String
[Seek] = "Seek" End Property
Public Property Get [Select]() As String
[Select] = "Select" End Property
Public Property Get [Set]() As String
[Set] = "Set" End Property
Public Property Get [Scale]() As String
[Scale] = "Scale" End Property
Public Property Get [Shared]() As String
[Shared] = "Shared" End Property
Public Property Get [Single]() As String
[Single] = "Single" End Property
Public Property Get [Static]() As String
[Static] = "Static" End Property
Rem Keyword in VB6, demoted to contextual Public Property Get [Spc]() As String
[Spc] = "Spc" End Property
Rem Contextual in VB6 Public Property Get [Step]() As String
[Step] = "Step" End Property
Rem Keyword in VB6, demoted to contextual Public Property Get [Tab]() As String
[Tab] = "Tab" End Property
Public Property Get [Stop]() As String
[Stop] = "Stop" End Property
Public Property Get [String]() As String
[String] = "String" End Property
Public Property Get [Sub]() As String
[Sub] = "Sub" End Property
Rem Contextual in VB6 Public Property Get [Text]() As String
[Text] = "Text" End Property
Public Property Get [Then]() As String
[Then] = "Then" End Property
Public Property Get [To]() As String
[To] = "To" End Property
Public Property Get [True]() As String
[True] = "True" End Property
Public Property Get [Type]() As String
[Type] = "Type" End Property
Public Property Get [TypeOf]() As String
[TypeOf] = "TypeOf" End Property
Public Property Get [Unlock]() As String
[Unlock] = "Unlock" End Property
Public Property Get [Until]() As String
[Until] = "Until" End Property
Public Property Get [Variant]() As String
[Variant] = "Variant" End Property
Public Property Get [Void]() As String Rem Intentionally blank End Property
Public Property Get [Wend]() As String
[Wend] = "Wend" End Property
Public Property Get [While]() As String
[While] = "While" End Property
Rem Contextual in VB6 Public Property Get [Width]() As String
[Width] = "Width" End Property
Public Property Get [With]() As String
[With] = "With" End Property
Public Property Get [WithEvents]() As String
[WithEvents] = "WithEvents" End Property
Public Property Get [Write]() As String
[Write] = "Write" End Property
Public Property Get [Xor]() As String
[Xor] = "Xor" End Property 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
Public FileNumber As IExpression Public Value As IExpression
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 Output_ As KeyedList
Public FileNumber As IExpression
Private Sub Class_Initialize() Set Output_ = New KeyedList Set Output_.T = New ExprValidator End Sub
Private Property Get IStmt_Kind() As StmtNumbers
IStmt_Kind = snWrite End Property
Public Property Get Output() As KeyedList Set Output = Output_ End Property End Class
Public Module ForwardCompatibility Option Explicit
Public Const vbLongLong = 20 Public Const vbLongPtr = 37
Public Enum [LongPtr]
Zero End Enum End Module
Private Module Globals Option Explicit
Public NameBank As New NameBank Public V As New Vocabulary Public x As New Messages
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 = Precedence(LeftOp) Dim RHS As Integer = Precedence(RightOp)
If LHS = RHS Then Exit Function
If LHS < RHS Then
ComparePrecedence = -1 Else
ComparePrecedence = 1 End If End Function
Private Function Precedence(ByVal Op As Operator) As Integer Select Case Op.Value.Code Case opApply
Precedence = 19
Case Else Debug.Assert False End Select End Function
Public Sub EnsureIdExists(ByVal Token As Token) Dim Name As String
Debug.Assert Token.Kind <> tkIdentifier
With NameBank
Name = .Item(Token) If Not .Ids.Exists(Name) Then .Ids.Add Name, Name
Token.Code = .Ids.IndexOf(Name) + .Keywords.Count + .Contextuals.Count
Token.Kind = tkIdentifier End With End Sub End Module
Public Module Program Option Explicit Option Compare Binary
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 Text 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 Dim FilePath As String = 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. Dim Index As Integer = InStrRev(FilePath, ".") If Index <> 0 Then FilePath = Left$(FilePath, Index - 1)
FilePath &= ".html" Dim HtmlFile As Integer = FreeFile Open FilePath For Output Access Write As #HtmlFile
Dim Nbsp As Boolean = 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 If Left$(Token.Text, 1) = "-"Then Print #HtmlFile, "-"; Print #HtmlFile, Mid$(Token.Text, 2);
Nbsp = False
Case tkEscapedIdentifier Print #HtmlFile, "["; NameBank(Token.Text); "]";
Nbsp = False
Case tkKeyword Print #HtmlFile, SPAN_KEYWORD; NameBank(Token); "</span>";
Nbsp = False
Case tkBinaryNumber If Left$(Token.Text, 1) = "-"Then Print #HtmlFile, "-"; Print #HtmlFile, "&B"; Mid$(Token.Text, 2);
Case tkOctalNumber If Left$(Token.Text, 1) = "-"Then Print #HtmlFile, "-"; Print #HtmlFile, "&O"; Mid$(Token.Text, 2);
Case tkHexaNumber If Left$(Token.Text, 1) = "-"Then Print #HtmlFile, "-"; Print #HtmlFile, "&H"; UCase$(Mid$(Token.Text, 2));
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()
IsInit_ = True Dim Bytes() As Byte = LoadResData(101, "CUSTOM") Dim Size As Long = 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 Result As String = Text
For Pos = 1 To Len(Text) Dim Ch As String * 1 = Mid$(Result, Pos, 1)
Select Case Ch Case"A"To"Z" Exit Select
Case"a"To"z"
Cp = AscW(Ch)
Ch = ChrW$(Cp - 32)
Case Else If Not IsInit_ Then Init
Cp = AscW(Ch) Dim Index As Long = 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 Result As String = Text
For Pos = 1 To Len(Text) Dim Ch As String * 1 = Mid$(Result, Pos, 1)
Case Else If Not IsInit_ Then Init
Cp = AscW(Ch) Dim Index As Long = 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 Pos As Long Dim Index As Long
Dim Result As String = Text Dim ToUp As Boolean = True
For Pos = 1 To Len(Text) Dim Ch As String * 1 = Mid$(Result, Pos, 1) Dim Cp As Integer = AscW(Ch)
If IsLetter(Cp) Then If ToUp Then
ToUp = False
Select Case Ch Case"A"To"Z" Exit Select
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 MiddlePoint As Long
Dim ResultIndex As Long = FirstIndex - 1 Dim RightPoint As Long = UBound(SourceArray) - Step + 1 + FirstIndex Dim LeftPoint As Long = FirstIndex
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 AndAlso Character <= -9217 OrElse Character >= 55296 AndAlso 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 AndAlso Character <= -8193 OrElse Character >= 56320 AndAlso Character <= 57343 End Function
Public Function IsSurrogate(ByVal Character As Integer) As Boolean
IsSurrogate = IsLowSurrogate(Character) OrElse 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 += 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 += 1
Rem Return it.
AddRefEntry = This.Count End Function
Public Function ReleaseEntry(ByRef This As IEnumVariantType) As Long Rem Decrement reference 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