Metamorphing Machine
I rather be this walking metamorphosis than having that old formed opinion about everything!
Let's build a transpiler! Part 36
This is the thirty-sixth post in a series of building a transpiler.
You can find the previous ones here.
To bytes and back
VB6 has a nice feature: It has seamless conversion between string and array of bytes and vice-versa.
From string to bytes:
Dim Bytes() As Byte
Bytes = "Hi, world!"
'Bytes now is: 'Bytes(0) -> 72 = H 'Bytes(1) -> 0 'Bytes(2) -> 105 = i 'Bytes(3) -> 0 'Bytes(4) -> 44 = , 'Bytes(5) -> 0 'Bytes(6) -> 32 = <space> 'Bytes(7) -> 0 'Bytes(8) -> 119 = w 'Bytes(9) -> 0 'Bytes(10) -> 111 = o 'Bytes(11) -> 0 'Bytes(12) -> 114 = r 'Bytes(13) -> 0 'Bytes(14) -> 108 = l 'Bytes(15) -> 0 'Bytes(16) -> 100 = d 'Bytes(17) -> 0 'Bytes(18) -> 33 = ! 'Bytes(19) -> 0
As ou can see, each character is composed of two bytes / an Integer.
From bytes to string:
Dim S As String
S = Bytes
Debug.Print s 'It prints "Hi, world!"
Even though technically a VB String is null-terminated, this null terminator is not included in the byte array.
Back to business
A couple of weeks back I said we would convert the entire project to VBScript again.
In doing that I stumbled upon "new" VBScript's restrictions:
Static is invalid. It cannot be used in Subs, Functions, Propertys, or to declare variables. I had to upgrade those variables to class-scoped ones.
Compiler directives (#If, #Else, etc.) don't make sense to an interpreted script, so they had to go, too.
To my surprise, one cannot declare Consts inside classes. They had to be lifted to the script's scope.
Implements does not work. As every variable has Variant type, there's no way we can implicitly convert an interface variable to a class one using assignment as we have been doing.
Due to this last point, I decided to get rid of all Validators.
Not only TypeOf does not exist in VBScript, but I had some issues in validating Empty values that were supposed to be Strings.
Another issue related to not being able to use interfaces is that CallConstruct now cannot return ekIndexer through its IExpression_Kind property
and snCall through IStmt_Kind.
It does not implement any interface anymore, but we still need to know which expression or statement we are dealing with,
so these two Kind properties were merged into one and the ekIndexer value was adjusted to have the same value as snCall.
So it does not matter now if the Kind property is being called to some statement checking or expression checking; it will work for both.
Everything you wanted to know about not providing optional parameters but was afraid to ask
Last time we converted our project to a script, we provided every optional argument. This time we will do something different:
We will move every optional parameter to a position before the mandatory ones.
It means we will transform this:
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
Into this:
Private Function NewToken(ByVal Code, ByVal Text, ByVal Suffix, ByVal Kind)
Then we'll trace every function call and will not provide those optional arguments!
If the call was "Set GetToken = NewToken(tkEndOfStream)" we'll change it to "Set GetToken = NewToken(, , , tkEndOfStream)".
Now, when the call is made during runtime, VBScript will fill these blanks with an error value. We can detect it using the function below:
Function IsMissing(Value)
IsMissing = VarType(Value) = vbError End Function
Then, inside the called function we detect that the parameter is missing and provide a default value to it:
If IsMissing(Suffix) Then Suffix = vbNullChar
If you remember, our KeyedList class had two similar methods: Add, that receives a value and an optional key, and AddKeyValue, that receives a mandatory key then a mandatory value.
As we had to change Add due to its optional parameter, AddKeyValue became redundant, so I removed it.
Moving optional parameters before mandatory ones just works for procedures having at least one mandatory argument.
If all it has is one optional argument, we are back to providing a default value at its call site.
Which brings us to our next topic: NextToken has only one parameter, and is an optional one.
And it is called thousands of times without providing it.
Actually, it is only provided when pretty-printing. If there's something I am not going to do is chase every NextToken call to provide a useless argument there.
What I did instead was to change NextToken's name to InternalNextToken and made it Private.
Then I created a new Public NextToken that calls InternalGetToken providing it a dummy argument.
Then I created a new NextTokenForPrint that properly calls NextToken and changed the only call to NextToken in PrettyPrint to it instead.
Bullet adverted. Phew!
For Each try a fail
Back to KeyedList, I've found out there's no fraking way to implement IEnumVARIANT in VBScript.
I was not happy. No happy at all. I've spent too much time trying to make it work but came up empty-handed... Lesson learned I guess.
I had to resort to gathering all KeyedList's elements in an array, return the array through the NewEnum function, and call NewEnum explicitly in every For Each throughout the code.
An argument by any other name
I think named arguments are good to document code and did not like to have them removed the first time I came up with the script.
This time I'm doing something different: I've created a Named function that accepts a text and a value and returns that value.
So I used the text part to document the reason for the argument being provided. Even though it is a pretty useless function, I'd liked it:
Set Handle_ = .OpenTextFile(Value, ForWriting, Named("Create:=", True), Named("Format:=Unicode", True))
GoTo considered... annoying
As we improved our code, I had reintroduced a couple of GoTos, but now have to get rid of them again.
You will see that I factored out the common code into a SubGoTo1 function and a SubGoTo2 sub.
I don't think the outcome is better, though.
I still pretty much prefer the original code.
Vocabulary class
No much to see here. Vocabulary was a module and now is a class.
Why I did it? Well, suppose Vocabulary's words are not hardcoded into it but instead are read from a configuration file.
It means that, in theory, we could parse and transpile keywords that are not English, but maybe... Spanish? Welsh? Latin? Oh, the possibilities...
VBScript bugs
You already know about default methods and that they are supported by VBScript. Unfortunately, they do not work as they should.
If we have a class with a default property and are directly using an instance of it, everything is OK. This works:
Option Explicit
Class Greeter Public Default Property Get SayHi(Name)
SayHi = "Hi, " & Name End Property End Class
Dim Greet Set Greet = New Greeter
MsgBox Greet("Biasic")
But if we get the instance in a "second hand" way, then we get a "Wrong number of arguments or invalid property assignment" error message:
Class GreeterBearer Private Greeter_
Private Sub Class_Initialize() Set Greeter_ = New Greeter End Sub
Public Property Get Greeter() Set Greeter = Greeter_ End Property End Class
Dim Bearer = New GreeterBearer
MsgBox Bearer.Greeter("Biasic") '<-It does not work!
My solution was to delete every Property Get whose only purpose was to mimic read-only access to an internal variable and expose that variable as public instead.
Not pretty, but worked.
The second issue is that I could not make VBScript understand that while class Parser does have a Scanner property,
when I'm Newing Scanner, I meant "Scanner" to be the class, not the property (that is not Newable anyways...)
When I ran the script I was "greeted" twice by the error "Class not defined: Scanner". It confused the hell out of me for no less than three fraking whole days!
That's why I renamed the Scanner class to Tokenizer. Life is too short...
Heh... What about your bugs?
I was almost forgetting... We had a bug that I workarounded it by appending a line break at the end of the source file.
To do the same in VBScript, we would need to 1) open the file for reading, 2) read all the text, and 3) check if it ended with a line break.
If it didn't, we'd 4) append a line break to the text we just read, 5) close the file, 6) open for writing, 7) write the new text over the old one,
8) close the file, and 9) open it for reading again so we can start parsing it... It does not seem like a workaround anymore.
Fortunately, the fix is simple: We just add tkEndOfStream as an accepted line break in IsBreak function.
That's it. No need to fuss with source files anymore.
Now you know my adventures and perils in translating VB6 to VBScript.
Enjoy the new version of the script below.
Dim Result: Result = AscW(Left(Letter, 1)) If Result >= SMALL_A Then Result = Result - SMALL_A + CAPITAL_A If Result < CAPITAL_A Or Result > CAPITAL_Z Then Result = CAPITAL_A - 1
Result = Result - CAPITAL_A
ToIndex = Result End Function End Class
Class DoConstruct Public Body Public Condition Public DoType
Private Sub Class_Initialize() Set Body = New KeyedList Set Condition = Nothing End Sub
Public Property Get Kind()
Kind = snDo End Property End Class
Class EndConstruct Public Property Get Kind()
Kind = snEnd End Property End Class
Class Entity Public Consts Public Enums Public Declares Public Events Public Impls Public Vars Public Types Public Subs Public Functions Public Properties Public DefTypes Public OptionBase Public OptionCompare Public OptionExplicit Public IsClass Public Accessibility Public Id
Private Sub Class_Initialize()
OptionBase = 0
Set Consts = New KeyedList
Consts.CompareMode = vbTextCompare
Set Enums = New KeyedList
Enums.CompareMode = vbTextCompare
Set Declares = New KeyedList
Declares.CompareMode = vbTextCompare
Set Events = New KeyedList
Events.CompareMode = vbTextCompare
Set Impls = New KeyedList
Impls.CompareMode = vbTextCompare
Set Vars = New KeyedList
Vars.CompareMode = vbTextCompare
Set Types = New KeyedList
Types.CompareMode = vbTextCompare
Set Subs = New KeyedList
Subs.CompareMode = vbTextCompare
Set Functions = New KeyedList
Functions.CompareMode = vbTextCompare
Set Properties = New KeyedList
Properties.CompareMode = vbTextCompare
Set DefTypes = New DefType Set Id = Nothing End Sub End Class
Class EnumConstruct Public Enumerands Public Access Public Id
Private Sub Class_Initialize() Set Enumerands = New KeyedList
Enumerands.CompareMode = vbTextCompare
Set Id = Nothing End Sub End Class
Class EnumerandConstruct Public Access Public Id Public Value
Private Sub Class_Initialize() Set Id = Nothing Set Value = Nothing End Sub End Class
Class EraseConstruct Public Vars
Private Sub Class_Initialize() Set Vars = New KeyedList End Sub
Public Property Get Kind()
Kind = snErase End Property End Class
Class EventConstruct Public Parameters Public Id
Private Sub Class_Initialize() Set Parameters = New KeyedList
Parameters.CompareMode = vbTextCompare
Set Id = Nothing End Sub
Public Property Get Access()
Access = acPublic End Property End Class
Class ExitConstruct Public What
Public Property Get Kind()
Kind = snExit End Property End Class
Class Expressionist Private LastToken_
Public CanHaveTo Public FullMode
Private Sub Class_Initialize() Set LastToken_ = Nothing End Sub
Public Property Get LastToken() Set LastToken = LastToken_ End Property
Private Function Peek(ByVal Stack) Set Peek = Stack(Stack.Count) End Function
Private Function Pop(ByVal Stack) Dim Index: Index = Stack.Count Set Pop = Stack(Index)
Stack.Remove Index End Function
Rem Adapted from https://stackoverflow.com/questions/16380234/handling-extra-operators-in-shunting-yard/16392115#16392115 Public Function GetExpression(ByVal Token, ByVal Parser) Dim HadTo, Cp, Sym, Lit, Op, Handle, Args
If IsMissing(Token) Then Set Token = Nothing
Dim OpStack: Set OpStack = New KeyedList Dim OutStack: Set OutStack = New KeyedList Dim WantOperand: WantOperand = True
Do If Token Is Nothing Then Set Token = Parser.NextToken
If WantOperand Then
WantOperand = False
Select Case Token.Kind Case tkOperator
WantOperand = True
Select Case Token.Code Case opSum
Token.Code = opId
Case opSubt
Token.Code = opNeg
Rem Unary operators Case opAddressOf, opNew, opNot, opTypeOf, opWithBang, opWithDot Rem OK
Case Else Exit Do End Select
Set Op = NewOperator(Token)
OpStack.Add , Op
Case tkLeftParenthesis Rem Pseudo-operator Set Op = NewOperator(Token)
OpStack.Add , Op
WantOperand = True
Case tkIdentifier, tkEscapedIdentifier Set Sym = New Symbol Set Sym.Value = Token
OutStack.Add , Sym
Case tkIntegerNumber, tkFloatNumber, tkSciNumber, tkBinaryNumber, _
tkOctalNumber, tkHexaNumber, tkString, tkDateTime Set Lit = New Literal Set Lit.Value = Token
OutStack.Add , Lit
Case tkFileHandle Set Handle = New FileHandle Set Handle.Value = Token
OutStack.Add , Handle
Case tkKeyword Select Case Token.Code Case kwTrue, kwFalse, kwNothing, kwEmpty, kwNull, kwMe Set Lit = New Literal Set Lit.Value = Token
OutStack.Add , Lit
Case kwInput, kwSeek Set Sym = New Symbol Set Sym.Value = Token
OutStack.Add , Sym
Case kwByVal
Token.Kind = tkOperator
Token.Code = opByVal If SubGoTo1(Token, OpStack, OutStack) Then Exit Do
WantOperand = True
Case Else Exit Do End Select
Case Else Exit Do End Select Else If Parser.IsBreak(Token) Then While OpStack.Count > 0
Move , OpStack, OutStack Wend
Exit Do End If
Select Case Token.Kind Case tkOperator If SubGoTo1(Token, OpStack, OutStack) Then Exit Do
WantOperand = True
Case tkRightParenthesis Do While OpStack.Count > 0 Set Op = Peek(OpStack) If Op.Value.Kind = tkLeftParenthesis Then Exit Do
Move Op, OpStack, OutStack Loop
Rem It is allowed to not have a "(" on OpStack because we can be evaluating the following: Rem Sub A(Optional B As Integer = 1) Rem We'll get to ")" without having ")" on stack. If OpStack.Count = 0 Then Exit Do
Pop OpStack
Case tkKeyword If Token.Code <> kwTo Then Exit Do
If Not CanHaveTo Or HadTo Then Err.Raise vbObjectError + 13
HadTo = True
Set Args = New TupleConstruct Set Token = CollectArgs(, Args.Elements, Parser) If Token.Kind <> tkRightParenthesis Then Fail Token, Msg036, Msg057
OutStack.Add , Args
Case Else Exit Do End Select End If
Set Token = Nothing Loop
Set LastToken_ = Token
Do While OutStack.Count > 1 Or OutStack.Count = 1 And OpStack.Count > 0 Set Op = Peek(OpStack) If Op.Value.Kind = tkLeftParenthesis Then Exit Do
Move Op, OpStack, OutStack Loop
If OutStack.Count = 1 Then Set GetExpression = Pop(OutStack) Else Set GetExpression = Nothing End Function
Private Function SubGoTo1(ByVal Token, ByVal OpStack, ByVal OutStack) Rem Unary and compound operators Select Case Token.Code Case opAddressOf, opNew, opNot, opTypeOf
Parser.Fail , Token, Msg065
Case opCompAnd, opCompEqv, opCompImp, _
opCompMod, opCompOr, opCompXor, opCompSum, opCompSubt, opCompMul, opCompDiv, _
opCompIntDiv, opCompPow, opCompLSh, opCompRSh, opCompURSh, opCompConcat
SubGoTo1 = True Exit Function End Select
Dim Op2: Set Op2 = NewOperator(Token)
Do While OpStack.Count > 0 Dim Op: Set Op = Peek(OpStack) If Op.Value.Kind = tkLeftParenthesis Then Exit Do
Dim Cp: Cp = ComparePrecedence(Op, Op2) If Cp = -1 Then Exit Do
Move Op, OpStack, OutStack Loop
OpStack.Add , Op2 End Function
Private Sub Move(ByVal Op, ByVal OpStack, ByVal OutStack) Dim Elem
If IsMissing(Op) Then Set Op = Nothing Dim IExpr: Set IExpr = Nothing Dim Uni: Set Uni = Nothing Dim Bin: Set Bin = Nothing Dim Exec: Set Exec = Nothing Dim Tup: Set Tup = Nothing
If Op Is Nothing Then Set Op = Peek(OpStack)
If Op.IsUnary Then Set Uni = New UnaryExpression Set Uni.Operator = Op Set Uni.Value = Pop(OutStack) Set IExpr = Uni
ElseIf Op.Value.Code = opApply Then Set Exec = New CallConstruct Set Tup = Pop(OutStack)
For Each Elem In Tup.Elements.NewEnum
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 Token, ByVal LookAhead, ByVal Parser) Dim Done, Sym
If IsMissing(Token) Then Set Token = Nothing If IsMissing(LookAhead) Then Set LookAhead = Nothing Dim Result: Set Result = Nothing Dim Name: Set Name = Nothing Dim Expr: Set Expr = Nothing Dim Asg: Set Asg = Nothing Dim Exec: Set Exec = Nothing Dim Bin: Set Bin = Nothing Dim Xp: Set Xp = New Expressionist
If Token Is Nothing Then Set Token = Parser.NextToken
If Token.Kind = tkOperator Then If Token.Code = opWithBang Or Token.Code = opWithDot Then Dim Uni: Set Uni = New UnaryExpression Set Uni.Operator = NewOperator(Token) Set Token = Parser.NextToken If Token.Kind <> tkIdentifier And Token.Kind <> tkEscapedIdentifier Then Stopp 1
Set Sym = New Symbol Set Sym.Value = Token Set Uni.Value = Sym Set Name = Uni Else
Stopp 2 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(Token, Exec.Arguments, Parser) Set Result = Exec
Case opDot Set Bin = New BinaryExpression Set Bin.Operator = NewOperator(Token) Set Bin.LHS = Name
Set Token = Parser.NextToken If Token.Kind <> tkIdentifier And Token.Kind <> tkEscapedIdentifier Then Exit Do
Set Sym = New Symbol Set Sym.Value = Token Set Bin.RHS = Sym
Set Name = Bin
Set Token = Parser.NextToken
Done = False
Case opEq Set Asg = New LetConstruct Set Asg.Operator = NewOperator(Token) Set Asg.Name = Name
Xp.FullMode = True Set Asg.Value = Xp.GetExpression(, Parser) Set Token = Xp.LastToken If Asg.Value Is Nothing Then Exit Do
Set Result = Asg
Case opSum Rem Identity operator. We'll ignore it. Set Exec = New CallConstruct Set Exec.LHS = Name Set Token = CollectArgs(, Exec.Arguments, Parser) Set Result = Exec
Case opSubt Rem Operator is being passed to CollectArgs through Token argument.
Token.Code = opNeg Set Exec = New CallConstruct Set Exec.LHS = Name Set Token = CollectArgs(Token, Exec.Arguments, Parser) Set Result = Exec
Set Asg = New LetConstruct Set Asg.Operator = NewOperator(Token) Set Asg.Name = Name
Xp.FullMode = True
Asg.Value = Xp.GetExpression(, Parser) Set Token = Xp.LastToken If Asg.Value Is Nothing Then Exit Do 'We'll return Nothing to sign a problem.
Set Result = Asg End Select
Case tkIdentifier, tkEscapedIdentifier Set Exec = New CallConstruct Set Exec.LHS = Name
Rem Identifier is being passed to CollectArgs through Token Set Token = CollectArgs(Token, Exec.Arguments, Parser) 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(Token, Exec.Arguments, Parser) Set Result = Exec
Case kwDate, kwString
Token.Kind = tkIdentifier Set Exec = New CallConstruct Set Exec.LHS = Name Set Token = CollectArgs(Token, Exec.Arguments, Parser) Set Result = Exec
Case kwEmpty, kwFalse, kwMe, kwNothing, kwNull, kwTrue Set Exec = New CallConstruct Set Exec.LHS = Name Set Token = CollectArgs(Token, Exec.Arguments, Parser) 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(Token, Exec.Arguments, Parser) 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
Public Function CollectArgs(ByVal Token, ByVal Args, ByVal Parser) If IsMissing(Token) Then Set Token = Nothing Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
If Not Token Is Nothing Then If Token.Kind = tkListSeparator Then
Token.Kind = tkKeyword
Token.Code = kwVoid
Dim Lit: Set Lit = New Literal Set Lit.Value = Token
Args.Add , Lit Set Token = Nothing End If End If
Do Dim Expr: Set Expr = Xp.GetExpression(Token, Parser) Set Token = Xp.LastToken
If Expr Is Nothing Then Select Case Token.Kind Case tkRightParenthesis Exit Do
Case tkListSeparator Dim Tkn: 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 Then Exit Do If Token.Kind <> tkListSeparator Then Exit Do Set Token = Nothing Loop
Set CollectArgs = Token End Function End Class
Class FileHandle Public Value
Private Sub Class_Initialize() Set Value = Nothing End Sub
Public Property Get Kind()
Kind = ekFileHandle End Property End Class
Class FileTextBuilder Private IsNewLine_ Private Indent_ Private Handle_
Public Property Let FilePath(ByVal Value) With CreateObject("Scripting.FileSystemObject") Set Handle_ = .OpenTextFile(Value, ForWriting, Named("Create:=", True), Named("Format:=Unicode", True)) End With End Property
Private Sub Class_Terminate()
Handle_.Access End Sub
Public Sub Append(ByVal Text) If IsNewLine_ Then
Handle_.WriteLine If Indent_ > 0 Then Handle_.Access Access(Indent_, vbTab) End If
IsNewLine_ = False
Handle_.Access Text End Sub
Public Sub AppendLn(ByVal Text) If Text = ""Then If IsNewLine_ Then Handle_.WriteLine Else
Append Text End If
IsNewLine_ = True End Sub
Public Sub Deindent()
Indent_ = Indent_ - 1 End Sub
Public Sub Indent()
Indent_ = Indent_ + 1 End Sub End Class
Class ForConstruct Public Body Public Counter Public StartValue Public EndValue Public Increment
Private Sub Class_Initialize() Set Body = New KeyedList Set Counter = Nothing Set StartValue = Nothing Set EndValue = Nothing Set Increment = Nothing End Sub
Public Property Get Kind()
Kind = snFor End Property End Class
Class ForEachConstruct Public Body Public Element Public Group
Private Sub Class_Initialize() Set Body = New KeyedList Set Element = Nothing Set Group = Nothing End Sub
Public Property Get Kind()
Kind = snForEach End Property End Class
Class FunctionConstruct Public Parameters Public Body Public Access Public IsStatic Public IsDefault Public IsIterator Public Id Public DataType
Private Sub Class_Initialize() Set Parameters = New KeyedList
Parameters.CompareMode = vbTextCompare
Set Body = New KeyedList Set Id = Nothing Set DataType = Nothing End Sub End Class
Class GetConstruct Public FileNumber Public RecNumber Public Var
Private Sub Class_Initialize() Set FileNumber = Nothing Set RecNumber = Nothing Set Var = Nothing End Sub
Public Property Get Kind()
Kind = snGet End Property End Class
Class GoSubConstruct Public Target
Private Sub Class_Initialize() Set Target = Nothing End Sub
Public Property Get Kind()
Kind = snGoSub End Property End Class
Class GoToConstruct Public Target
Private Sub Class_Initialize() Set Target = Nothing End Sub
Public Property Get Kind()
Kind = snGoTo End Property End Class
Class Identifier Private Name_ Private Project_
Private Sub Class_Initialize() Set Name_ = Nothing Set Project_ = Nothing End Sub
Public Property Get Name() Set Name = Name_ End Property
Public Property Set Name(ByVal Value) If Not Name_ Is Nothing Then Set Project_ = Name_ Set Name_ = Value End Property
Public Property Get Project() Set Project = Project_ End Property End Class
Class IfArm Public Body Public Condition
Private Sub Class_Initialize() Set Body = New KeyedList Set Condition = Nothing End Sub End Class
Class IfConstruct Public Arms Public ElseBody
Private Sub Class_Initialize() Set Arms = New KeyedList Set ElseBody = New KeyedList End Sub
Public Property Get Kind()
Kind = snIf End Property End Class
Class ImplementsConstruct Private Id_
Private Sub Class_Initialize() Set Id_ = New Identifier End Sub
Public Property Get Id() Set Id = Id_ End Property End Class
Class InputConstruct Public Vars Public FileNumber
Private Sub Class_Initialize() Set Vars = New KeyedList Set FileNumber = Nothing End Sub
Public Property Get Kind()
Kind = snInput End Property End Class
Private Sub Class_Initialize()
Id_ = &H80000000
Base = 1
Set Root_ = Nothing Set Last_ = Nothing Set Validator_ = Nothing End Sub
Private Sub Class_Terminate()
ReadOnly_ = False
Clear End Sub
Public Sub Add(ByVal Key, ByVal Item) Const Id = "72E0DEDF0CD34921A650C8DD99F21A68_"
Dim NewKey
If ReadOnly_ Then Err.Raise 5 If Not Validator_ Is Nothing Then: If Not Validator_.Validate(Item) Then Err.Raise 13
Select Case VarType(Key) Case vbString
NewKey = CStr(Key)
Case vbError
NewKey = Id & Hex(Id_)
Id_ = Id_ + 1
Case Else
Err.Raise 13 End Select
If Root_ Is Nothing Then Set Root_ = New KLNode
Root_.Key = NewKey If IsObject(Item) Then Set Root_.Value = Item Else Root_.Value = Item Set Last_ = Root_
Else If Not FindNode(NewKey) Is Nothing Then Err.Raise 457
Dim NewNode: Set NewNode = New KLNode
NewNode.Key = NewKey If IsObject(Item) Then Set NewNode.Value = Item Else NewNode.Value = Item
Set Last_.NextNode = NewNode Set Last_ = NewNode End If
Count_ = Count_ + 1 End Sub
Public Property Get Count()
Count = Count_ End Property
Public Default Property Get Item(ByVal Index) Dim Node: 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)
Exists = Not FindNode(Key) Is Nothing End Property
Public Property Get Base()
Base = Base_ End Property
Public Property Let Base(ByVal Value) If ReadOnly_ Then Err.Raise 5
Base_ = Value End Property
Public Property Get CompareMode()
CompareMode = CompareMode_ End Property
Public Property Let CompareMode(ByVal Value) If ReadOnly_ Then Err.Raise 5
CompareMode_ = Value End Property
Public Sub Remove(ByVal Index) Dim Found, Idx, Key
If ReadOnly_ Then Err.Raise 5 Dim PrvNode: Set PrvNode= Nothing Dim CurNode: Set CurNode = Root_
If VarType(Index) = vbString Then
Key = CStr(Index)
Do Until CurNode Is Nothing If StrComp(CurNode.Key, Key, CompareMode) = 0 Then If Not PrvNode Is Nothing Then Set PrvNode.NextNode = CurNode.NextNode
Found = True Exit Do End If
Set PrvNode = CurNode Set CurNode = CurNode.NextNode Loop Else
Idx = CLng(Index)
Idx = Idx - Base
Do Until CurNode Is Nothing If Idx = 0 Then If CurNode Is Root_ Then Set Root_ = CurNode.NextNode
ElseIf Not PrvNode Is Nothing Then Set PrvNode.NextNode = CurNode.NextNode End If
If CurNode Is Last_ Then Set Last_ = PrvNode
Found = True Exit Do End If
Idx = Idx - 1 Set PrvNode = CurNode Set CurNode = CurNode.NextNode Loop End If
If Found Then Count_ = Count_ - 1 Else Err.Raise 5 End Sub
Public Function NewEnum() Dim Result, Node, Idx
If Count_ = 0 Then
Result = Array() Else ReDim Result(Count_ - 1) Set Node = Root_
Idx = 0
Do Until Node Is Nothing If IsObject(Node.Value) Then Set Result(Idx) = Node.Value Else Result(Idx) = Node.Value
Idx = Idx + 1 Set Node = Node.NextNode Loop End If
NewEnum = Result End Function
Public Sub Clear() Dim NextNode
If ReadOnly_ Then Err.Raise 5 Dim CurrNode: 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) Dim Idx, Node
If VarType(Index) = vbString Then Set Node = FindKey(CStr(Index)) Else Set Node = Nothing
Idx = CLng(Index)
Idx = Idx - Base
If Idx >= 0 Then Set Node = Root_
Do Until Node Is Nothing Or Idx = 0 Set Node = Node.NextNode
Idx = Idx - 1 Loop End If End If
Set FindNode = Node End Function
Private Function FindKey(ByVal Key) Dim Node: 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
Set FindKey = Nothing End Function
Public Property Get IndexOf(ByVal Key) Dim Count
Dim Node: Set Node = Root_
Do Until Node Is Nothing If StrComp(Node.Key, Key, CompareMode) = 0 Then
IndexOf = Count + Base Exit Property End If
Set Node = Node.NextNode
Count = Count + 1 Loop End Property
Public Sub AddValues(Values) Dim Value
For Each Value In Values
Add Value Next End Sub
Public Sub AddKVPairs(KeyValuePairs) Dim Idx
Dim Udx: Udx = UBound(KeyValuePairs) If Udx Mod 2 = 0 Then Err.Raise 5
For Idx = 0 To Udx Step 2
Add KeyValuePairs(Idx + 1), KeyValuePairs(Idx) Next End Sub
Public Property Get ReadOnly()
ReadOnly = ReadOnly_ End Property
Public Property Let ReadOnly(ByVal Value) If ReadOnly_ Then Err.Raise 5
ReadOnly_ = Value End Property
Public Property Set T(ByVal Value) Set Validator_ = Value End Property End Class
Class KLNode Public NextNode Public Key Public Value
Private Sub Class_Initialize() Set NextNode = Nothing End Sub End Class
Class LabelConstruct Public Id
Private Sub Class_Initialize() Set Id = Nothing End Sub
Public Property Get Kind()
Kind = snLabel End Property End Class
Class LetConstruct Public Name Public Operator Public Value
Private Sub Class_Initialize() Set Name = Nothing Set Operator = Nothing Set Value = Nothing End Sub
Public Property Get Kind()
Kind = snLet End Property End Class
Class LineNumberConstruct Public Value
Private Sub Class_Initialize() Set Value = Nothing End Sub
Public Property Get Kind()
Kind = snLineNumber End Property End Class
Class Literal Public Value
Private Sub Class_Initialize() Set Value = Nothing End Sub
Public Property Get Kind()
Kind = ekLiteral End Property End Class
Class LockConstruct Public FileNumber Public RecordRange
Private Sub Class_Initialize() Set FileNumber = Nothing Set RecordRange = Nothing End Sub
Public Property Get Kind()
Kind = snLock End Property End Class
Class LSetConstruct Public Name Public Value
Private Sub Class_Initialize() Set Name = Nothing Set Value = Nothing End Sub
Public Property Get Kind()
Kind = snLSet End Property End Class
Class NameBank Public Ids Public Keywords Public Operators Public Contextuals
Private Sub Class_Initialize() Dim Value
Set Ids = New KeyedList
Ids.CompareMode = vbTextCompare
Set Keywords = New KeyedList
Keywords.CompareMode = vbTextCompare
For Each Value In Values
Operators.Add Value, Value Next
Operators.ReadOnly = True End Sub
Public Default Function Item(ByVal Token) 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
Class NameConstruct Public OldPathName Public NewPathName
Private Sub Class_Initialize() Set OldPathName = Nothing Set NewPathName = Nothing End Sub
Public Property Get Kind()
Kind = snName End Property End Class
Class OnComputedConstruct Public Targets Public Value Public IsGoTo
Private Sub Class_Initialize() Set Targets = New KeyedList Set Value = Nothing End Sub
Public Property Get Kind()
Kind = snOnComputed End Property End Class
Class OnErrorConstruct Public Statement
Private Sub Class_Initialize() Set Statement = Nothing End Sub
Public Property Get Kind()
Kind = snOnError End Property End Class
Class OpenConstruct Public PathName Public FileMode Public FileAccess Public FileLock Public FileNumber Public Length
Private Sub Class_Initialize() Set PathName = Nothing Set FileNumber = Nothing Set Length = Nothing End Sub
Public Property Get Kind()
Kind = snOpen End Property End Class
Class Operator Public Value
Private Sub Class_Initialize() Set Value = Nothing End Sub
Public Property Get IsUnary() Select Case Value.Code Case opAddressOf, opNew, opNot, opTypeOf, opId, opNeg, opWithDot, opWithBang, opByVal
IsUnary = True End Select End Property
Public Property Get IsBinary()
IsBinary = Not IsUnary End Property End Class
Class Parameter Public Index Public IsOptional Public IsByVal Public IsParamArray Public IsArray Public DataType Public Id Public Init
Private Sub Class_Initialize() Set DataType = Nothing Set Id = Nothing Set Init = Nothing End Sub End Class
Class AccessToken Public Access Public Token
Private Sub Class_Initialize() Set Token = Nothing End Sub End Class
Private Property Let Middle(ByRef Text, ByVal Start, ByVal Length, ByVal Value)
Text = Left(Text, Start - 1) & Value & Mid(Text, Start + Length) End Property
Private Function AtEnd()
AtEnd = File_.AtEndOfStream End Function
Public Sub OpenFile(ByVal FilePath)
FilePath_ = FilePath
With CreateObject("Scripting.FileSystemObject") If Not .FileExists(FilePath) Then Err.Raise 53 Set File_ = .OpenTextFile(FilePath, ForReading, Named("Create:=", False), Named("Format:=Unicode", True)) End With
Dim Cp: Cp = GetCodePoint If Cp <> &HFEFF Then UngetChar ChrW(Cp) End Sub
Public Function GetToken() Dim Token
If AtEnd Then Set GetToken = NewToken(, , , tkEndOfStream) Exit Function End If
Do Dim Done: Done = True
FrozenColumn_ = RunningColumn_ Dim Cp: Cp = GetCodePoint Dim Ch: Ch = ChrW(Cp)
Select Case Ch Case"[" Set Token = ReadEscapedIdentifier
Case"+" Set Token = NewToken(opSum, , , tkOperator)
Case"-" Set Token = NewToken(opSubt, , , tkOperator)
Case"*" Set Token = NewToken(opMul, , , tkOperator)
Case"/" Set Token = NewToken(opDiv, , , tkOperator)
Case"\" Set Token = NewToken(opIntDiv, , , tkOperator)
Case"^" Set Token = NewToken(opPow, , , tkOperator)
Case"=" Set Token = NewToken(opEq, , , tkOperator)
Case"." Set Token = NewToken(opDot, , , tkOperator)
Case"!" Set Token = NewToken(opBang, , , tkOperator)
Case"<" Set Token = NewToken(opLt, , , tkOperator)
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(opGt, , , tkOperator)
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(Named("IsRem:=", False))
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(Named("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() Dim CheckLF, Cp2, Cp3
Dim Cp1: 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() Dim Result
If UnChars_ = ""Then If AtEnd Then Fail "Unexpected end of file"
Result = File_.Read(1) Else
Result = Left(UnChars_, 1)
UnChars_ = Mid(UnChars_, 2) End If
RunningColumn_ = RunningColumn_ + 1
NextCodePoint = AscW(Result) End Function
Private Function GetChar() Dim Cp: Cp = GetCodePoint
GetChar = ChrW(Cp) End Function
Private Sub AdvanceLine()
RunningLine_ = RunningLine_ + 1
PreviousColumn_ = RunningColumn_
RunningColumn_ = 1 End Sub
Private Sub UngetChar(ByVal Character) Dim Length: Length = SizeOf(kwInteger) If Character = vbBack Then Length = Length * 2 + Len(vbNewLine) * SizeOf(kwInteger)
UnChars_ = Character & UnChars_
Select Case Character Case vbLf, vbBack
RunningLine_ = RunningLine_ - 1
RunningColumn_ = PreviousColumn_ End Select
RunningColumn_ = RunningColumn_ - IIf(Character = vbBack, 2, 1) End Sub
Private Sub Fail(ByVal Msg)
Err.Raise vbObjectError + 13, "Scanner", FilePath_ & "(" & RunningLine_ & ", " & FrozenColumn_ & ") " & Msg End Sub
Private Function ReadIdentifier(ByVal CodePoint) Const MAX_LENGTH = 255 Dim Ch
Dim Suffix: Suffix = vbNullChar Dim Buffer: Buffer = Access(MAX_LENGTH, vbNullChar)
Dim Count: Count = 1
Middle(Buffer, Count, 1) = ChrW(CodePoint)
Do Until AtEnd Dim Cp: Cp = GetCodePoint
Ch = ChrW(Cp)
Dim IsOK: IsOK = Ch = "_" If Not IsOK Then IsOK = Ch >= "0"And Ch <= "9" If Not IsOK Then IsOK = IsLetter(Cp) If Not IsOK Then IsOK = IsSurrogate(Cp) If Not IsOK Then Exit Do
Count = Count + 1 If Count > MAX_LENGTH Then Fail "Identifier too long"
Middle(Buffer, Count, 1) = Ch Loop
Dim Result: Set Result = NewToken(, , Suffix, tkIdentifier) Dim Name: Name = Left(Buffer, Count) Dim Index: Index = NameBank_.Keywords.IndexOf(Name)
If Index <> 0 Then
Result.Kind = tkKeyword Else
Index = NameBank_.Operators.IndexOf(Name)
If Index <> 0 Then
Result.Kind = tkOperator Else
Index = NameBank_.Contextuals.IndexOf(Name)
If Index <> 0 Then
Index = Index + NameBank_.Keywords.Count Else
Index = NameBank_.Ids.IndexOf(Name)
If Index = 0 Then
NameBank_.Ids.Add Name, Name
Index = NameBank_.Ids.Count End If
Index = Index + NameBank_.Keywords.Count + NameBank_.Contextuals.Count End If End If End If
Select Case Result.Kind Case tkKeyword, tkOperator If Result.Suffix <> vbNullChar Then If Index = kwString And Result.Suffix = "$"Then
Result.Kind = tkIdentifier If Not NameBank_.Ids.Exists("String") Then NameBank_.Ids.Add "String", "String"
Index = NameBank_.Ids.IndexOf("String") + NameBank_.Keywords.Count + NameBank_.Contextuals.Count Else
Fail "Keyword or operator cannot have type-declaration character" End If End If End Select
Result.Code = Index Set ReadIdentifier = Result End Function
Private Function ReadEscapedIdentifier() Const MAX_LENGTH = 255
Dim Count
Dim Suffix: Suffix = vbNullChar Dim Buffer: Buffer = Access(MAX_LENGTH, vbNullChar)
Do Until AtEnd Dim Cp: Cp = GetCodePoint If Cp = AscW("]") Then Exit Do If Cp = LF_ Then Fail "Invalid identifier"
Count = Count + 1 If Count > MAX_LENGTH Then Fail "Identifier too long"
Middle(Buffer, Count, 1) = ChrW(Cp) Loop
If Not AtEnd Then
Suffix = GetChar
Select Case Suffix Case"%", "&", "^", "@", "!", "#", "$" Rem OK
Case Else
UngetChar Suffix
Suffix = vbNullChar End Select End If
Dim Token: Set Token = NewToken(, , Suffix, tkEscapedIdentifier) Dim Name: Name = Left(Buffer, Count)
Token.Code = NameBank_.Ids.IndexOf(Name)
If Token.Code = 0 Then
NameBank.Ids.Add Name, Name
Token.Code = NameBank.Ids.Count End If
Set ReadEscapedIdentifier = Token End Function
Private Function ReadString() Const MAX_LENGTH = 1013
Dim Count, Ch
Dim Buffer: Buffer = Access(MAX_LENGTH, vbNullChar)
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(, Named("Text:=", Left(Buffer, Count)), , tkString) End Function
Private Function Append(ByVal Count, ByRef Buffer, ByVal Ch)
Count = Count + 1
Middle(Buffer, Count, 1) = Ch
Append = Count End Function
Private Function ReadInteger(ByVal FirstDigit) Const MAX_LENGTH = 29
Dim Count
Dim Suffix: Suffix = vbNullChar Dim Buffer: Buffer = Access(MAX_LENGTH, vbNullChar)
If FirstDigit >= "0"And FirstDigit <= "9"Then
Count = 1
Middle(Buffer, Count, 1) = FirstDigit End If
Do Until AtEnd If Count = MAX_LENGTH Then Fail "Literal too long" Dim Cp: Cp = GetCodePoint Dim Ch: Ch = ChrW(Cp)
Set ReadInteger = NewToken(, Named("Text:=", Left(Buffer, Count)), Suffix, tkIntegerNumber) End Function
Private Function ReadFloat(ByVal FirstDigit) Dim Result: Set Result = ReadInteger(FirstDigit)
If Result.Suffix = vbNullChar Then If Not AtEnd Then Dim Ch: Ch = GetChar
If Ch = "."Then Dim FracPart: Set FracPart = ReadInteger("") If FracPart.Text = ""Then Fail "Invalid literal"
Result.Text = Result.Text & "." & FracPart.Text
Result.Kind = tkFloatNumber
Result.Suffix = FracPart.Suffix Else
UngetChar Ch End If End If End If
Set ReadFloat = Result End Function
Private Function ReadNumber(ByVal FirstDigit) Dim Result: Set Result = ReadFloat(FirstDigit)
If Result.Suffix = vbNullChar Then If Not AtEnd Then Dim Ch: Ch = GetChar
Select Case Ch Case"e", "E" If AtEnd Then
UngetChar Ch Else Dim Sg: Sg = GetChar
If Sg = "-"Or Sg = "+"Then
Ch = "" Else
Ch = Sg
Sg = "+" End If
Dim ExpPart: Set ExpPart = ReadInteger(Named("FirstDigit:=", Ch)) If ExpPart.Text = ""Or ExpPart.Suffix <> vbNullChar Then Fail "Invalid literal"
Result.Text = Result.Text & "E" & Sg & ExpPart.Text
Result.Kind = tkSciNumber End If
Case Else
UngetChar Ch End Select End If End If
Set ReadNumber = Result End Function
Private Function ReadAmpersand() Dim Token
Dim Ch: Ch = GetChar
Select Case Ch Case"b", "B" Set Token = ReadBin
Case"o", "O" Set Token = ReadOctal
Case"h", "H" Set Token = ReadHexa
Case"=" Set Token = NewToken(opCompConcat, , , tkOperator)
Case Else
UngetChar Ch Set Token = NewToken(opConcat, , , tkOperator) End Select
Set ReadAmpersand = Token End Function
Private Function ReadBin() Set ReadBin = ReadBOH(ReadBinChars_, 96, tkBinaryNumber) End Function
Private Function ReadOctal() Set ReadOctal = ReadBOH(ReadOctalChars_, 32, tkOctalNumber) End Function
Private Function ReadHexa() Set ReadHexa = ReadBOH(ReadHexaChars_, 24, tkHexaNumber) End Function
Private Function ReadHash() Dim Name
Rem Let's get the first number. Dim Token: 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(, Named("Text:=", Name), , tkDirective) Exit Function
Case""
Fail Msg_
Case Else Dim Number: 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(, Named("Text:=", Name), , tkFileHandle) Exit Function End If
Token.Text = CStr(Number) End Select End If
Rem Let's get the first separator. Dim Cp: Cp = GetCodePoint Dim Ch: Ch = ChrW(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(, Named("Text:=", Name), , tkDateTime) 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(, Named("Text:=", ReadTime("")), , tkDateTime) 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(, Named("Text:=", Name & " 00:00:00"), , tkDateTime)
Case Else
Fail Msg_ End Select End Function
Private Function ReadDate(ByVal FirstNumber, ByVal Separator) Dim YYYY, MM, DD, Result
Dim SecondNumber: Set SecondNumber = ReadInteger("") If SecondNumber.Text = ""Then Fail Msg_
Rem The next separator must match the first one. Dim Ch: Ch = GetChar If Ch <> Separator Then Fail Msg_
Dim ThirdNumber: Set ThirdNumber = ReadInteger("") If ThirdNumber.Text = ""Then Fail Msg_
If CInt(FirstNumber) >= 100 And Separator = "-"Then
YYYY = CInt(FirstNumber)
MM = CInt(SecondNumber.Text)
DD = CInt(ThirdNumber.Text) Else
MM = CInt(FirstNumber)
DD = CInt(SecondNumber.Text)
YYYY = CInt(ThirdNumber.Text)
If YYYY < 100 Then
YYYY = YYYY + 1900 If YYYY < 1950 Then YYYY = YYYY + 100 End If End If
Rem Validate year. If YYYY > 9999 Then Fail Msg_
Rem Validate month. If MM < 1 Or MM > 12 Then Fail Msg_
Rem Validate day. Select Case MM Case 4, 6, 9, 11 If DD > 30 Then Fail Msg_
Case 2 If YYYY Mod 4 = 0 And YYYY Mod 100 <> 0 Or YYYY Mod 400 = 0 Then If DD > 29 Then Fail Msg_ Else If DD > 28 Then Fail Msg_ End If
Case Else If DD > 31 Then Fail Msg_ End Select
Rem Put it together in YYYY-MM-DD format. If YYYY < 1000 Then Result = "0" If YYYY < 100 Then Result = Result & "0" If YYYY < 10 Then Result = Result & "0"
Result = Result & CStr(YYYY)
Result = Result & "-"
If MM < 10 Then Result = Result & "0"
Result = Result & CStr(MM)
Result = Result & "-"
If DD < 10 Then Result = Result & "0"
Result = Result & CStr(DD)
ReadDate = Result End Function
Private Function ReadTime(ByVal FirstNumber) Dim SS, Ch2, AP
Dim HH: HH = CInt(FirstNumber) Dim Number: Number = ReadInteger("") If Number = ""Then Err.Raise 0 Dim NN: NN = CInt(Number)
Dim Ch: Ch = GetChar
If Ch = ":"Then
Number = ReadInteger("") If Number = ""Then Err.Raise 0
SS = CInt(Number) Else
UngetChar Ch End If
If Not AtEnd Then
Ch = GetChar
If Ch = " "Then If Not AtEnd Then
Ch = GetChar
If Ch = "a"Or Ch = "A"Then
Ch2 = GetChar
If Ch2 = "m"Or Ch2 = "M"Then
AP = "A" Else
UngetChar Ch2
UngetChar Ch
UngetChar " " End If
ElseIf Ch = "p"Or Ch = "P"Then
Ch2 = GetChar
If Ch2 = "m"Or Ch2 = "M"Then
AP = "P" Else
UngetChar Ch2
UngetChar Ch
UngetChar " " End If
Else
UngetChar Ch
UngetChar " " End If End If Else
UngetChar Ch End If End If
Rem Validate hour, minute, and second. If HH < 0 Or HH > 23 Then Err.Raise 0 If NN < 0 Or NN > 59 Then Err.Raise 0 If SS < 0 Or SS > 59 Then Err.Raise 0
If AP = "A"Then If HH = 12 Then HH = 0
ElseIf AP = "P"Then If HH <> 12 Then HH = HH + 12 End If
Rem Put it together in HH:NN:SS format.
Number = CStr(SS) If SS < 10 Then Number = "0" & Number
Number = ":" & Number
Number = CStr(NN) & Number If NN < 10 Then Number = "0" & Number
Number = ":" & Number
Number = CStr(HH) & Number If HH < 10 Then Number = "0" & Number
ReadTime = Number End Function
Private Function ReadMonthName() Dim Result, Prv Dim Ch: Ch = vbNullChar
Do Until AtEnd
Prv = Ch
Ch = GetChar
Select Case Ch Case"#", vbLf, ",", ";", ")", " "
UngetChar Ch Exit Do
Case"0", "1", "2", "3", "4", "5", "6", "7", "8", "9" Rem We safely can assume we read two characters more than needed.
UngetChar Ch
UngetChar Prv
Result = Left(Result, Len(Result) - 1) Exit Do
Case Else
Result = Result & Ch End Select Loop
ReadMonthName = Result End Function
Private Function ConvertNameToNumber(ByVal Name) Dim Count, Result, MonthName
For Each MonthName In MonthNames_
Count = Count + 1
If StrComp(Name, MonthName, vbTextCompare) = 0 Then Result = Count If Result = 0 Then: If StrComp(Name, Left(MonthName, 3), vbTextCompare) = 0 Then Result = Count If Result <> 0 Then Exit For Next
ConvertNameToNumber = Result End Function
Private Function NewToken( _ ByVal Code, _ ByVal Text, _ ByVal Suffix, _ ByVal Kind _
) If IsMissing(Code) Then Code = 0 If IsMissing(Text) Then Text = "" If IsMissing(Suffix) Then Suffix = vbNullChar
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(ByVal IsRem) Const MAX_LENGTH = 1013
Dim Text
Dim Buffer: Buffer = Access(MAX_LENGTH, vbNullChar)
If IsRem Then
Text = v.Rem & " " Else
Text = " '" End If
Dim Count: Count = Len(Text)
Middle(Buffer, 1, Count) = Text
Do Until AtEnd If Count = MAX_LENGTH Then Fail "Comment too long" Dim Ch: Ch = GetChar If Ch = vbLf Then Exit Do
Private Sub Class_Initialize() Set Scanner_ = New Tokenizer Set LastToken_ = Nothing Set LookAhead_ = Nothing Set Source_ = Nothing End Sub
Public Property Set SourceFile(ByVal Source) Set Scanner_ = New Tokenizer 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() Set SourceFile = Source_ End Property
Public Property Get Scanner() Set Scanner = Scanner_ End Property
Public Function NextTokenForPrint() Set NextTokenForPrint = InternalNextToken(True) End Function
Public Function NextToken() Set NextToken = InternalNextToken(False) End Function
' 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. Private Function InternalNextToken(ByVal ForPrint) Dim Done, Revoke, Upgrade, Spaces, Name
Dim Token: Set Token = Nothing Dim LastToken: Set LastToken = Nothing
Do
Done = True
If LookAhead_ Is Nothing Then Set Token = Scanner_.GetToken Else Set Token = LookAhead_ Set LookAhead_ = Nothing End If
If IsEndOfContext(Token) Then
State_ = ncNone Else Select Case Token.Kind Case tkOperator
WasAs_ = False
Downgrade_ = Token.Code = opDot Or Token.Code = opBang
If Spaces <> 0 Then If Token.Code = opDot Then
Token.Code = opWithDot ElseIf Token.Code = opBang Then
Token.Code = opWithBang End If End If
Case tkKeyword If Downgrade_ Then
Downgrade_ = False
Name = NameBank_(Token)
If NameBank_.Ids.Exists(Name) Then
NameBank_.Ids.Add Name, Name
Token.Code = NameBank_.Ids.Count End If
Token.Kind = tkIdentifier
Else Select Case Token.Code Case kwAs
WasAs_ = True
Select Case State_ Case ncOpen03, ncOpen05, ncOpen06, ncOpen08, ncOpen09
State_ = ncOpen10 End Select
Case kwDate, kwString If Not WasAs_ Then Token.Kind = tkIdentifier
Case kwDeclare If State_ = ncNone Then State_ = ncDeclare
Case kwFor If State_ = ncNone Then
State_ = ncForNext
ElseIf State_ = ncOpen01 Then
State_ = ncOpen02 End If
Case kwInput If State_ = ncOpen02 Then State_ = ncOpen03
Case cxLock Select Case State_ Case ncOpen05, ncOpen06
State_ = ncOpen07 End Select
Case kwOpen If State_ = ncNone Then State_ = ncOpen01
Case kwOption If State_ = ncNone Then State_ = ncOption
Case kwOn If State_ = ncNone Then State_ = ncOn
Case cxShared Select Case State_ Case ncOpen03, ncOpen04, ncOpen06
State_ = ncOpen09 End Select
Case kwTo If State_ = ncForNext Then State_ = ncForTo
Case kwWrite Select Case State_ Case ncOpen04, ncOpen05
State_ = ncOpen06
Case ncOpen07, ncOpen08
State_ = ncOpen09 End Select End Select End If
Case tkIdentifier
Downgrade_ = False
WasAs_ = False
Select Case State_ Case ncNone Select Case Token.Code Case cxLine Set LookAhead_ = Scanner_.GetToken
Upgrade = LookAhead_.Kind = tkKeyword And LookAhead_.Code = kwInput
Case cxName, cxReset
Upgrade = LastToken_.Kind <> tkKeyword Or LastToken_.Code <> kwCall
If Upgrade Then Set LastToken = LastToken_ Set LastToken = Token Set LookAhead_ = NextToken() Set LastToken_ = LastToken
If Upgrade Then
Upgrade = LookAhead_.Kind <> tkKeyword Or LookAhead_.Code <> kwAs End If
If Upgrade Then Upgrade = LookAhead_.Kind <> tkOperator If Upgrade Then Upgrade = LookAhead_.Kind <> tkLeftParenthesis If Upgrade Then Upgrade = Not IsEndOfContext(LookAhead_) End If
Case cxWidth Set LookAhead_ = Scanner_.GetToken
Upgrade = LookAhead_.Kind = tkFileHandle End Select
Case ncOption
Upgrade = Token.Code = cxBase If Not Upgrade Then Upgrade = Token.Code = cxExplicit
If Not Upgrade Then
Upgrade = Token.Code = cxCompare If Upgrade Then State_ = ncOptionCompare End If
Case ncOptionCompare
Upgrade = Token.Code = cxBinary If Not Upgrade Then Upgrade = Token.Code = cxText
Case ncDeclare
Upgrade = Token.Code = 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 = Spaces + 1
Case tkSoftLineBreak, tkHardLineBreak
WasAs_ = False End Select
If Upgrade Then If Token.Suffix <> vbNullChar Then Fail , Token, Msg060
Token.Kind = tkKeyword
Name = NameBank_(Token)
Token.Code = NameBank_.Contextuals.IndexOf(Name) + NameBank_.Keywords.Count If Revoke Then State_ = ncNone End If End If
If Token.Kind <> tkWhiteSpace Then Set LastToken_ = Token Loop Until Done
If Token.Kind <> tkHardLineBreak And Token.Spaces = 0 Then Token.Spaces = Spaces Set InternalNextToken = Token End Function
Rem Parses Source's content. Rem Results are in Source's properties like Consts, Enums, etc. Public Sub Parse(ByVal Source) Dim Name, Token, Mark, Entity
Dim AccessToken: Set AccessToken = New 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 Msg001, Token, Msg007
Else
Fail Msg002, Token, Msg007 End If
Set Mark = Token
If Entity.Accessibility = acLocal Then Entity.Accessibility = acPublic Set Token = NextToken If Not IsProperId(, Token) Then Fail Msg003, Token, Msg007
Set Entity.Id = NewId(Token)
MustEatLineBreak
Set 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 v.End, Token, Msg004 End If
Set Token = NextToken If Not Token.IsKeyword(IIf(Entity.IsClass, kwClass, kwModule)) Then Fail , Token, Msg085 & NameBank_(Mark)
Name = NameBank_(Entity.Id.Name) If Source_.Entities.Exists(Name) Then Fail , Entity.Id.Name, Msg006 & Name
Source_.Entities.Add Name, Entity
MustEatLineBreak Loop End Sub
Private Function ParseDeclarationArea(ByVal Entity) Dim HadBase, HadCompare, Text, Access, Token
Do Set Token = SkipLineBreaks
If Token.Kind = tkKeyword Then Select Case Token.Code Case kwOption If Access <> acLocal Then Fail Msg003, Token, Msg008 Set Token = NextToken If Token.Kind <> tkKeyword Then Fail v.Option, Token, Msg015
Select Case Token.Code Case cxBase If HadBase Then Fail , Token, Msg010
HadBase = True
Set Token = NextToken '''' Remove heading zeros ''''
Text = Token.Text
Do If Left(Text, 1) <> "0"Then Exit Do
Text = Mid(Text, 2) Loop
If Text = ""Then Text = "0" ''''''''''''''''''''''''''''''
If Token.Kind <> tkIntegerNumber Or (Text <> "0"And Text <> "1") Then
Fail "0 or 1", Token, Msg011 End If
Entity.OptionBase = IIf(Text = "0", 0, 1)
Case cxCompare If HadCompare Then Fail , Token, Msg010
HadCompare = True
Set Token = NextToken If Token.Kind <> tkKeyword Then Fail Msg014, Token, Msg013
Select Case Token.Code Case cxBinary
Entity.OptionCompare = vbBinaryCompare
Case cxText
Entity.OptionCompare = vbTextCompare
Case Else
Fail Msg014, Token, Msg013 End Select
Case cxExplicit If Entity.OptionExplicit Then Fail , Token, Msg010
Entity.OptionExplicit = True
Case Else
Fail v.Option, Token, Msg015 End Select
Case kwDefBool If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbBoolean, Entity
Case kwDefByte If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbByte, Entity
Case kwDefInt If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbInteger, Entity
Case kwDefLng If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbLong, Entity
Case kwDefLngLng If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbLongLong, Entity
Case kwDefLngPtr If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbLongPtr, Entity
Case kwDefCur If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbCurrency, Entity
Case kwDefDec If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbDecimal, Entity
Case kwDefSng If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbSingle, Entity
Case kwDefDbl If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbDouble, Entity
Case kwDefDate If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbDate, Entity
Case kwDefStr If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbString, Entity
Case kwDefObj If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbObject, Entity
Case kwDefVar If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseDef vbVariant, Entity
Case kwPublic, kwGlobal If Access <> acLocal Then Fail Msg003, Token, Msg008
Access = acPublic
Case kwPrivate If Access <> acLocal Then Fail Msg003, Token, Msg008
Access = acPrivate
Case kwConst If Access = acLocal Then Access = acPrivate
ParseConsts , Access, Entity, Entity.Consts
Access = acLocal
Case kwEnum
ParseEnum Access, Entity
Access = acLocal
Case kwDeclare
ParseDeclare Access, Entity
Access = acLocal
Case kwEvent If Not Entity.IsClass Then Fail , Token, Msg016 If Access = acLocal Then Access = acPublic If Access <> acPublic Then Fail , Token, Msg017
ParseEvent Entity
Access = acLocal
Case kwImplements If Not Entity.IsClass Then Fail , Token, Msg016 If Access <> acLocal Then Fail Msg003, Token, Msg008
ParseImplements Entity
Case kwWithEvents If Access = acLocal Then Access = acPublic
ParseDim , , Token, Access, Entity, Entity.Vars
Access = acLocal
Case kwDim If Access = acLocal Then Access = acPublic
ParseDim , , , Access, Entity, Entity.Vars
Access = acLocal
Case kwType If Access = acLocal Then Access = acPublic
ParseType Access, Entity
Access = acLocal
Case kwFriend If Access <> acLocal Then Fail Msg003, Token, Msg008 If Not Entity.IsClass Then Fail , Token, Msg016
Access = acFriend Exit Do
Case kwStatic, kwIterator, kwDefault, kwSub, kwFunction, cxProperty, kwEnd Exit Do
Case Else
Fail , Token, Msg018 End Select
ElseIf Token.Kind = tkIdentifier And Token.Code = cxProperty Then
Token.Kind = tkKeyword Exit Do
Set Token = SkipLineBreaks If Token.Kind = tkIdentifier And Token.Code = cxProperty Then Token.Kind = tkKeyword Loop
Set ParseProcedureArea = Token End Function
Private Sub ParseDef(ByVal VariableType, ByVal Entity) Dim First, Last, Token, Mark
Do Set Token = SkipLineBreaks Set Mark = Token
If Token.Kind <> tkIdentifier Then Fail Msg020, Token, Msg019 If Token.Suffix <> vbNullChar Then Fail , Token, Msg060
First = NameBank_(Token) Set Token = NextToken
If Token.IsOperator(opSubt) Then Set Token = NextToken If Token.Kind <> tkIdentifier Or Token.Suffix <> vbNullChar Then Fail Msg021, Token, Msg019
Last = NameBank_(Token) Set Token = NextToken Else
Last = First End If
On Error Resume Next
Entity.DefTypes.SetRange First, Last, VariableType
If Err Then On Error GoTo 0
Fail , Token, Msg022 End If
On Error GoTo 0
If IsBreak(Token) Then Exit Do If Token.Kind <> tkListSeparator Then Fail ",", Token, Msg019 Loop End Sub
Private Function ParseConsts( _ ByVal InsideProc, _ ByVal Access, _ ByVal Entity, _ ByVal Body _
) Dim Name
If IsMissing(InsideProc) Then InsideProc = False Dim Token: Set Token = Nothing Dim Cnt: Set Cnt = Nothing Dim Xp: Set Xp = New Expressionist
Do Rem Get Const's name Set Token = SkipLineBreaks If Not IsProperId(, Token) Then Fail Msg003, Token, Msg023
Set Cnt = New ConstConstruct
Cnt.Access = Access Set Cnt.Id = NewId(Token)
Set Token = NextToken
Rem Do we have an As clause? If Token.IsKeyword(kwAs) Then If Token.Suffix <> vbNullChar Then Fail , Token, Msg024
Rem Get Const's data type name Set Token = NextToken If Not IsConstDataType(Token) Then Fail Msg025, Token, Msg023
Set Cnt.DataType = NewDataType(Token) Set Token = NextToken
If Token.IsOperator(opMul) Then If Cnt.DataType.Id.Name <> v.String Then Fail , Token, Msg026
Set Cnt.DataType.FixedLength = Xp.GetExpression(, Me) Set Token = Xp.LastToken If Cnt.DataType.FixedLength Is Nothing Then Fail , Token, Msg065 End If
ElseIf Cnt.Id.Name.Suffix <> vbNullChar Then Rem Assign DataType property based on type sufix Set Cnt.DataType = FromChar(Cnt.Id.Name.Suffix) End If
Rem Discard "=" If Not Token.IsOperator(opEq) Then Fail "=", Token, Msg023
Rem Get Const's value Set Cnt.Value = Xp.GetExpression(, Me) If Cnt.Value Is Nothing Then Fail , Token, Msg065
Rem Ensure it's not a duplicated Const If Not InsideProc Then CheckDupl , Entity, Cnt.Id.Name
Name = NameBank_(Cnt.Id.Name) If Body.Exists(Name) Then Fail , Cnt.Id.Name, Msg006 & Name
If Cnt.DataType Is Nothing Then Rem TODO: Infer its data type End If
Rem Save it
Body.Add 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 Msg027, Token, Msg023 Loop
Set ParseConsts = Token End Function
Private Sub ParseEnum(ByVal Access, ByVal Entity) Dim Emd
Dim Xp: Set Xp = New Expressionist Dim Token: Set Token = NextToken If Not IsProperId(, Token) Then Fail Msg003, Token, Msg028 If Token.Suffix <> vbNullChar Then Fail , Token, Msg029
Dim Enm: 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 Msg031, Token, Msg028
Do Set Token = SkipLineBreaks If Token.IsKeyword(kwEnd) Then Exit Do If Not IsProperId(, Token) Then Fail Msg003, Token, Msg032 If Token.Suffix <> vbNullChar Then Fail , Token, Msg033
Set Emd = New EnumerandConstruct
Emd.Access = Access Set Emd.Id = NewId(Token)
Set Token = NextToken
If Token.IsOperator(opEq) Then Set Emd.Value = Xp.GetExpression(, Me) Set Token = Xp.LastToken If Emd.Value Is Nothing Then Fail , Token, Msg065 End If
If Enm.Enumerands.Exists(NameBank_(Emd.Id.Name)) Then Fail , Emd.Id, Msg006 & NameBank_(Emd.Id.Name)
Enm.Enumerands.Add NameBank_(Emd.Id.Name), Emd Loop While IsBreak(Token)
If Not Token.IsKeyword(kwEnd) Then Fail v.End, Token, Msg034
Set Token = NextToken If Not Token.IsKeyword(kwEnum) Then Fail v.Enum, Token, Msg034
MustEatLineBreak
If Enm.Enumerands.Count = 0 Then Fail , Enm, Msg035
CheckDupl , Entity, Enm.Id.Name
Entity.Enums.Add NameBank_(Enm.Id.Name), Enm End Sub
Private Sub ParseDeclare(ByVal Access, ByVal Entity) Dim Dcl: Set Dcl = New DeclareConstruct If Access = acLocal Then Access = acPublic
Dcl.Access = Access
Rem Is it PtrSafe? Dim Token: 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 Msg037, Token, Msg036 End If
Rem Get its name. Set Token = NextToken If Not IsProperId(Named("CanHaveSuffix:=", True), Token) Then Fail Msg003, Token, Msg036
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 v.Lib, Token, Msg036
Rem Get Lib's name Set Token = NextToken If Token.Kind <> tkString Then Fail Msg038, Token, Msg036 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 Msg039, Token, Msg036
Set Dcl.AliasName = Token Set Token = NextToken End If
Rem Get its parameters. If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Entity, skDeclare, Dcl.Parameters)
Rem Maybe there's an "As" clause? If Token.IsKeyword(kwAs) Then Rem Can we have an "As" clause? If Dcl.IsSub Then Fail Msg031, Token, Msg036 If Token.Suffix <> vbNullChar Then Fail , Token, Msg024
Rem Get data type name Set Token = NextToken
Select Case Token.Kind Case tkIdentifier, tkEscapedIdentifier If Token.Suffix <> vbNullChar Then Fail , Token, Msg060 Set Dcl.DataType = NewDataType(Token) Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Not IsProperId(, Token) Then Fail Msg025, Token, Msg036
Set Dcl.DataType.Id.Name = Token Set Token = NextToken End If
Case tkKeyword If Not IsBuiltinDataType(Token) Then Fail Msg025, Token, Msg036 Set Dcl.DataType = NewDataType(Token) Set Token = NextToken
Case Else
Fail Msg025, Token, Msg036 End Select
Rem Maybe it returns an array? If Token.Kind = tkLeftParenthesis Then Set Token = NextToken If Token.Kind <> tkRightParenthesis Then Fail Msg057, Token, Msg036
Dcl.DataType.IsArray = True
Set Token = NextToken End If End If
If Dcl.IsSub Then Dim Tkn: Set Tkn = New Token
Tkn.Kind = tkKeyword
Tkn.Code = kwVoid
Set Dcl.DataType = NewDataType(Tkn)
ElseIf Dcl.DataType Is Nothing Then If Dcl.Id.Name.Suffix = vbNullChar Then Set Dcl.DataType = Entity.DefTypes(NameBank_(Dcl.Id.Name)) Else Set Dcl.DataType = FromChar(Dcl.Id.Name.Suffix) End If End If
Rem Ensure it is not duplicated.
CheckDupl , Entity, Dcl.Id.Name
Rem Must end with a line break If Not IsBreak(Token) Then MustEatLineBreak
Entity.Declares.Add NameBank_(Dcl.Id.Name), Dcl End Sub
Private Function ParseParms(ByVal Entity, ByVal SignatureKind, ByVal Parms) Dim Count, Index, Name, CurrParm
Dim Xp: Set Xp = New Expressionist Dim LastParm: Set LastParm = New Parameter Dim Token: Set Token = NextToken If Token.Kind = tkLeftParenthesis Then Set Token = NextToken
If Token.Kind <> tkRightParenthesis Then Do Set CurrParm = New Parameter
CurrParm.Index = Index
Index = Index + 1 If Index >= 60 Then Fail , Token, Msg042
If Token.IsKeyword(kwOptional) Then If LastParm.IsParamArray Then Fail , Token, Msg043 If SignatureKind = skEvent Or SignatureKind = skTuple Then Fail , Token, Msg044
CurrParm.IsOptional = True Set Token = NextToken
ElseIf Token.IsKeyword(kwParamArray) Then If LastParm.IsOptional Then Fail , Token, Msg043 If SignatureKind = skEvent Or SignatureKind = skTuple Then Fail , Token, Msg045
CurrParm.IsParamArray = True Set Token = NextToken End If
If Not CurrParm.IsParamArray Then If Token.IsKeyword(kwByVal) Then If SignatureKind = skTuple Then Fail , Token, Msg046
CurrParm.IsByVal = True Set Token = NextToken
ElseIf Token.IsKeyword(kwByRef) Then If SignatureKind = skTuple Then Fail , Token, Msg047
CurrParm.IsByVal = False 'Technically this is not needed Set Token = NextToken End If End If
If Not IsProperId(Named("CanHaveSuffix:=", True), Token) Then Fail Msg003, Token, Msg041 Set CurrParm.Id = NewId(Token)
Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = NextToken If Token.Kind <> tkRightParenthesis Then Fail ")", Token, Msg041
CurrParm.IsArray = True Set Token = NextToken End If
If CurrParm.IsParamArray And Not CurrParm.IsArray Then Fail , CurrParm.Id, Msg048
If Token.IsKeyword(kwAs) Then If CurrParm.Id.Name.Suffix <> vbNullChar Then Fail , Token, Msg049 Set Token = NextToken
If SignatureKind = skDeclare Then If Not IsDataType(Token) Then Fail Msg025, Token, Msg041 Else If Not IsProperDataType(Token) Then Fail Msg025, Token, Msg041 End If
Set CurrParm.DataType = NewDataType(Token) Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Not IsProperId(, Token) Then Fail Msg003, Token, Msg050
Set CurrParm.DataType.Id.Name = Token
If CurrParm.IsParamArray And ( _ Not CurrParm.DataType.Id.Project Is Nothing Or _
CurrParm.DataType.Id.Name.Code <> kwVariant) Then _
Fail , Token, Msg051
Set Token = NextToken End If
ElseIf CurrParm.Id.Name.Suffix <> vbNullChar Then Set CurrParm.DataType = FromChar(CurrParm.Id.Name.Suffix)
Else Set CurrParm.DataType = Entity.DefTypes(NameBank_(CurrParm.Id.Name)) End If
If Token.IsOperator(opEq) Then If Not CurrParm.IsOptional Then Fail , Token, Msg053 If CurrParm.IsParamArray Then Fail , Token, Msg054 Set CurrParm.Init = Xp.GetExpression(, Me) Set Token = Xp.LastToken If CurrParm.Init Is Nothing Then Fail , Token, Msg065 End If
If Not CurrParm.IsOptional And (LastParm.IsOptional Or LastParm.IsParamArray) Then If SignatureKind <> skPropertyLet And SignatureKind <> skPropertySet Then _
Fail v.Optional, CurrParm.Id, Msg041
GoSub AddParm Set Token = NextToken Exit Do End If
AddParm CurrParm, Parms, SignatureKind Set LastParm = CurrParm If Token.Kind <> tkListSeparator Then Exit Do Set Token = NextToken Loop End If
If SignatureKind = skPropertyLet Or SignatureKind = skPropertySet Then If Parms.Count = 0 Then
Fail , Token, Msg078
ElseIf LastParm.IsOptional Or LastParm.IsParamArray Then
Fail , LastParm.Id, Msg078 End If End If
If Token.Kind <> tkRightParenthesis Then Fail , Token, Msg057 Set ParseParms = NextToken End Function
Private Sub AddParm(ByVal CurrParm, ByVal Parms, ByVal SignatureKind) Dim Count
Dim Name: Name = NameBank_(CurrParm.Id.Name)
If Parms.Exists(Name) Then If SignatureKind <> skDeclare Then Fail , CurrParm.Id, Msg040
Count = 1
Do
Name = NameBank_(CurrParm.Id.Name) & "_" & CStr(Count) If Not Parms.Exists(Name) Then Exit Do
Count = Count + 1 Loop End If
Parms.Add Name, CurrParm End Sub
Private Sub ParseEvent(ByVal Entity) Dim Token: Set Token = SkipLineBreaks If Not IsProperId(, Token) Then Fail Msg003, Token, Msg012
Dim Evt: Set Evt = New EventConstruct Set Evt.Id = NewId(Token)
Set Token = NextToken If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Entity, skEvent, Evt.Parameters)
If Not IsBreak(Token) Then Fail Msg031, Token, Msg012
CheckDupl , Entity, Evt.Id.Name
Entity.Events.Add NameBank_(Evt.Id.Name), Evt End Sub
Private Sub ParseImplements(ByVal Entity) Dim Token: Set Token = SkipLineBreaks If Token.Kind <> tkIdentifier Then Fail Msg059, Token, Msg058 If Token.Suffix <> vbNullChar Then Fail , Token, Msg060
Dim Impls: 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 Msg003, Token, Msg058 If Token.Suffix <> vbNullChar Then Fail , Token, Msg060
Set Impls.Id.Name = Token Set Token = NextToken End If
If Not IsBreak(Token) Then Fail Msg031, Token, Msg058 Set Token = Impls.Id.Name Dim Name: Name = NameBank_(Token) If Entity.Impls.Exists(Name) Then Fail , Token, Msg006 & Name
Entity.Impls.Add Name, Impls End Sub
Private Function ParseSub(ByVal Access, ByVal Entity) If Access = acLocal Then Access = acPublic Dim Proc: Set Proc = New SubConstruct
Proc.Access = Access
Dim Token: Set Token = NextToken If Not IsProperId(, Token) Then Fail Msg003, Token, Msg069
Set Proc.Id = NewId(Token) Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Entity, skSub, Proc.Parameters)
ElseIf Not IsBreak(Token) Then
Fail Msg031, Token, Msg069 End If Set Token = ParseBody(, , Entity, Proc.Body) If Not Token.IsKeyword(kwSub) Then Fail v.Sub, Token, Msg072
MustEatLineBreak
Dim Name: Name = NameBank_(Proc.Id.Name)
CheckDupl , Entity, Proc.Id.Name
Entity.Subs.Add Name, Proc
Set ParseSub = Proc End Function
Private Function ParseFunction(ByVal Access, ByVal Entity) Dim Parm
If Access = acLocal Then Access = acPublic Set Func = New FunctionConstruct
Func.Access = Access
Dim Token: Set Token = NextToken If Not IsProperId(Named("CanHaveSuffix:=", True), Token) Then Fail Msg003, Token, Msg070
Dim Func: Set Func.Id = NewId(Token) Dim Name: Name = NameBank_(Func.Id.Name)
Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms(Entity, skFunction, Func.Parameters)
ElseIf Not IsBreak(Token) Then
Fail Msg031, Token, Msg070 End If
For Each Parm In Func.Parameters.NewEnum If StrComp(Name, NameBank_(Parm.Id.Name), vbTextCompare) = 0 Then Fail , Parm.Id.Name, Msg040 Next
If Token.IsKeyword(kwAs) Then Set Token = NextToken If Not IsProperDataType(Token) Then Fail Msg059, Token, Msg050 Set Func.DataType = NewDataType(Token)
Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Not IsProperId(, Token) Then Fail Msg003, Token, Msg050
Set Func.DataType.Id.Name = Token Set Token = NextToken End If
ElseIf Func.Id.Name.Suffix <> vbNullChar Then Set Func.DataType = FromChar(Func.Id.Name.Suffix)
Else Set Func.DataType = Entity.DefTypes(Name) End If
If Token.Kind = tkLeftParenthesis Then Set Token = NextToken If Token.Kind <> tkRightParenthesis Then Fail , Token, Msg057
Func.DataType.IsArray = True End If
If Not IsBreak(Token) Then MustEatLineBreak Set Token = ParseBody(, , Entity, Func.Body) If Not Token.IsKeyword(kwFunction) Then Fail v.Function, Token, Msg073
MustEatLineBreak
If Entity.Properties.Exists(Name) Then Set Slot = Entity.Properties(Name) Else
IsNew = True Set Slot = New PropertySlot Set Slot.Id = NewId(Token) End If
Set Token = NextToken
If Token.Kind = tkLeftParenthesis Then Set Token = ParseParms( _
Entity, _
Switch(Kind = VbGet, skPropertyGet, Kind = VbLet, skPropertyLet, True, skPropertySet), _
Prop.Parameters _
)
ElseIf Not IsBreak(Token) Then
Fail Msg031, Token, Msg071 End If
If Kind = VbGet Then For Each Parm In Prop.Parameters.NewEnum If StrComp(Name, NameBank_(Parm.Id.Name), vbTextCompare) = 0 Then Fail , Parm.Id.Name, Msg040 Next
If Token.IsKeyword(kwAs) Then Set Token = NextToken If Not IsProperDataType(Token) Then Fail Msg059, Token, Msg050 Set Slot.DataType = NewDataType(Token)
Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken If Not IsProperId(, Token) Then Fail Msg003, Token, Msg050
Set Slot.DataType.Id.Name = Token Set Token = NextToken End If
ElseIf Slot.Id.Name.Suffix <> vbNullChar Then Set Slot.DataType = FromChar(Slot.Id.Name.Suffix)
Else Set Slot.DataType = Entity.DefTypes(Name) End If
If Token.Kind = tkLeftParenthesis Then Set Token = NextToken If Token.Kind <> tkRightParenthesis Then Fail , Token, Msg057
Slot.DataType.IsArray = True End If
ElseIf Prop.Parameters.Count = 0 Then
Fail , Slot.Id.Name, Msg078 End If
If Kind = VbSet Then If IsBuiltinDataType(Prop.Parameters(Prop.Parameters.Count).Id.Name) Then Fail , Slot.Id.Name, Msg077 End If
Set Token = ParseBody(, , Entity, Prop.Body) If Token.Kind <> tkIdentifier Or Token.Code <> cxProperty Then Fail , Token, Msg074
MustEatLineBreak
If IsNew Then
Entity.Properties.Add Name, Slot
ElseIf Slot.Exists(Kind) Then
Fail , PropToken, Msg006 & Name End If
Slot.Add Kind, Prop
If Kind <> VbGet Then Set Parm = Prop.Parameters(Prop.Parameters.Count) If Parm.IsOptional Then Fail , Slot.Id.Name, Msg077 If Parm.IsParamArray Then Fail , Slot.Id.Name, Msg077 End If
If Slot.Exists(VbGet) And Slot.Exists(VbLet) Then Set LeftParms = Slot(VbGet).Parameters Set RightParms = Slot(VbLet).Parameters If LeftParms.Count + 1 <> RightParms.Count Then Fail , Slot.Id.Name, Msg077
For Idx = 1 To LeftParms.Count If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail , LeftParms(Idx).Id.Name, Msg040 Next
If Kind = VbGet Then If Slot.DataType.IsArray <> RightParms(RightParms.Count).DataType.IsArray Then Fail , Slot.Id.Name, Msg077 If Slot.DataType.Id.Name.Code <> RightParms(RightParms.Count).DataType.Id.Name.Code Then _
Fail , Slot.Id.Name, Msg077 End If End If
If Slot.Exists(VbGet) And Slot.Exists(VbSet) Then Set LeftParms = Slot(VbGet).Parameters Set RightParms = Slot(VbSet).Parameters If LeftParms.Count + 1 <> RightParms.Count Then Fail , Slot.Id.Name, Msg077
For Idx = 1 To LeftParms.Count If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail , Slot.Id.Name, Msg077 Next End If
If Slot.Exists(VbLet) And Slot.Exists(VbSet) Then Set LeftParms = Slot(VbLet).Parameters Set RightParms = Slot(VbSet).Parameters If LeftParms.Count <> RightParms.Count Then Fail , Slot.Id.Name, Msg077
For Idx = 1 To LeftParms.Count - 1 If Not AreEqual(LeftParms(Idx), RightParms(Idx)) Then Fail , Slot.Id.Name, Msg077 Next End If
Set ParseProperty = Prop End Function
Private Sub ParseDim( _ ByVal InsideProc, _ ByVal IsStatic, _ ByVal Token, _ ByVal Access, _ ByVal Entity, _ ByVal Vars _
) Dim Name, WasArray, Var, Expr, Subs, Bin
If IsMissing(InsideProc) Then InsideProc = False If IsMissing(IsStatic) Then IsStatic = False If IsMissing(Token) Then Set Token = Nothing
If InsideProc Then: If Access = acPublic Or Access = acPrivate Then Fail , Token, Msg063 If Token Is Nothing Then Set Token = NextToken
Dim Xp: 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 Entity.IsClass Then Fail , Token, Msg016 If InsideProc Then Fail , Token, Msg063
Var.HasWithEvents = True Set Token = NextToken End If
If Not IsProperId(Named("CanHaveSuffix:=", True), Token) Then Fail Msg003, Token, Msg061 Set Var.Id.Name = Token
Set Token = NextToken
WasArray = False
If Token.Kind = tkLeftParenthesis Then Do Set Expr = Xp.GetExpression(, Me) Set Token = Xp.LastToken
If Not Expr Is Nothing Then Select Case Expr.Kind Case ekLiteral, ekSymbol, ekUnaryExpr Set Subs = New SubscriptPair Set Subs.LowerBound = SynthLower(Entity) Set Subs.UpperBound = Expr
Case ekBinaryExpr Set Bin = Expr Set Subs = New SubscriptPair
If Bin.Operator.Value.IsOperator(opTo) Then Set Subs.LowerBound = Bin.LHS Set Subs.UpperBound = Bin.RHS Else Set Subs.LowerBound = SynthLower(Entity) Set Subs.UpperBound = Expr End If
Case Else
Fail , Token, Msg065 End Select
Var.Subscripts.Add , Subs End If
If Token.Kind <> tkListSeparator Then Exit Do Loop
If Token.Kind <> tkRightParenthesis And Xp.LastToken.Kind <> tkRightParenthesis Then Fail , Token, Msg057
WasArray = True Set Token = NextToken End If
If Token.IsKeyword(kwAs) Then If Var.Id.Name.Suffix <> vbNullChar Then Fail , Token, Msg024 Set Token = NextToken
If Token.IsOperator(opNew) Then
Var.HasNew = True Set Token = NextToken End If
If Not IsProperDataType(Token) Then Fail Msg025, Token, Msg061 Set Var.DataType = NewDataType(Token)
If Var.HasNew And Var.DataType.Id.Name.Kind = tkKeyword Then Fail Msg059, Token, Msg062
Set Token = NextToken
If Token.IsOperator(opDot) Then Set Token = NextToken
If Not IsProperDataType(Token) Then Fail Msg003, Token, Msg061 Set Var.DataType.Id.Name = Token
Set Token = NextToken End If
ElseIf Var.Id.Name.Suffix <> vbNullChar Then Set Var.DataType = FromChar(Var.Id.Name.Suffix)
Else Set Var.DataType = Entity.DefTypes(NameBank_(Var.Id.Name)) End If
If Token.IsOperator(opMul) Then Set Var.DataType.FixedLength = Xp.GetExpression(, Me) Set Token = Xp.LastToken If Var.DataType.FixedLength Is Nothing Then Fail , Token, Msg065 End If
Var.DataType.IsArray = WasArray If Var.HasNew And Var.DataType.IsArray Then Fail , Token, Msg064
If Token.IsOperator(opEq) Then Set Var.Init = Xp.GetExpression(, Me) Set Token = Xp.LastToken If Var.Init Is Nothing Then Fail , Token, Msg065 End If
Name = NameBank_(Var.Id.Name) If Not InsideProc Then CheckDupl , Entity, Var.Id.Name If Vars.Exists(Name) Then Fail , Token, Msg006 & Name
Vars.Add Name, Var
If IsBreak(Token) Then Exit Do If Token.Kind <> tkListSeparator Then Fail ",", Token, Msg061 Set Token = NextToken Loop End Sub
Private Sub ParseType(ByVal Access, ByVal Entity) Dim Name, Var
Dim Ent: Set Ent = New Entity Dim Typ: Set Typ = New TypeConstruct
Typ.Access = Access
Dim Token: Set Token = NextToken If Not IsProperId(, Token) Then Fail Msg003, Token, Msg028
Set Typ.Id = NewId(Token)
MustEatLineBreak Set Token = Nothing 'Force ParseDim to get next token
Do
ParseDim , , Token, acLocal, Ent, Ent.Vars Rem Should not have "A As Boolean, B As ... If Ent.Vars.Count > 1 Then Fail Msg031, Ent.Vars(2).Id.Name, Msg067
Set Var = Ent.Vars(1) Rem Must have an explicit data type. If Var.DataType.Id.Name.Line = 0 Then Fail v.As, Var.DataType.Id.Name, Msg067
Rem Must not have an initial value If Not Var.Init Is Nothing Then Fail Msg031, Var.Init, Msg067
Ent.Vars.Clear
Name = NameBank_(Var.Id.Name) If Typ.Members.Exists(Name) Then Fail , Var.Id.Name, Msg006 & Name
Typ.Members.Add Name, Var Set Token = SkipLineBreaks Loop Until Token.IsKeyword(kwEnd)
Set Token = NextToken If Not Token.IsKeyword(kwType) Then Fail v.Type, Token, Msg068
Name = NameBank_(Typ.Id.Name)
CheckDupl , Entity, Var.Id.Name
Entity.Types.Add Name, Typ End Sub
Private Function ParseBody( _ ByVal IsSingleLine, _ ByVal LookAhead, _ ByVal Entity, _ ByVal Body _
) Dim Token, Stmt, LStmt, SStmt, Label, LinNum
If IsMissing(IsSingleLine) Then IsSingleLine = False If IsMissing(LookAhead) Then Set LookAhead = Nothing
Dim Xp: Set Xp = New Expressionist
Do If LookAhead Is Nothing Then Set Token = SkipLineBreaks Else Set Token = LookAhead Set LookAhead = Nothing If IsBreak(Token) Then Set Token = SkipLineBreaks End If
If Not IsSingleLine Then Rem Do we have a line number? If Token.Kind = tkIntegerNumber Then Set LinNum = New LineNumberConstruct Set LinNum.Value = Token
Body.Add , LinNum Set Token = NextToken End If
Rem Do we have a label? If Token.Kind = tkIdentifier Then Set LookAhead = NextToken
If LookAhead.Kind = tkSoftLineBreak Then Set Label = New LabelConstruct Set Label.Id = NewId(Token)
Body.Add , Label Set LookAhead = Nothing Set Token = NextToken End If End If End If
Select Case Token.Kind Case tkKeyword Select Case Token.Code Case kwCall Set Stmt = Xp.GetStmt(, , Me) Set LookAhead = Xp.LastToken If Stmt Is Nothing Then Fail , Token, Msg094 If Stmt.Kind <> snCall Then Stopp 3
Body.Add , Stmt
Case kwClose Set LookAhead = ParseClose(Entity, Body)
Case kwConst Set LookAhead = ParseConsts(Named("InsideProc:=", True), acLocal, Entity, Body)
Case kwContinue
ParseContinue Entity, Body
Case kwDebug Rem HACK: Set Stmt = Xp.GetStmt(Token, LookAhead, Me) Set LookAhead = Xp.LastToken If Stmt Is Nothing Then Fail , Token, Msg094
Body.Add , Stmt
Case kwDim
ParseDim Named("InsideProc:=", True), , , acLocal, Entity, Body
Case kwDo
ParseDo Entity, Body
Case kwEnd Rem Is it a closing End? Set LookAhead = NextToken
Select Case LookAhead.Kind Case tkKeyword Select Case LookAhead.Code Case kwFunction, kwIf, kwSelect, kwSub, kwWhile, kwWith Exit Do End Select
Case tkIdentifier If LookAhead.Code = cxProperty Then Exit Do End Select
Body.Add , New EndConstruct
Case kwErase Set LookAhead = ParseErase(Entity, Body)
Case kwExit
ParseExit Entity, Body
Case kwFor Set LookAhead = ParseFor(Entity, Body)
Case kwGet
ParseGet Entity, Body
Case kwGoSub
ParseGoSub Entity, Body
Case kwGoTo
ParseGoTo Entity, Body
Case kwIf Set LookAhead = ParseIf(Entity, Body)
Case kwInput Set LookAhead = ParseInput(Entity, Body)
Case kwLet Set Stmt = Xp.GetStmt(, , Me) Set LookAhead = Xp.LastToken If Stmt Is Nothing Then Fail , Token, Msg094 If Stmt.Kind <> snLet Then Stopp 4
Body.Add , Stmt
Case kwLSet Set LookAhead = ParseLSet(Entity, Body)
Case kwOn Set LookAhead = ParseOn(Entity, Body)
Case kwOpen Set LookAhead = ParseOpen(Entity, Body)
Case kwPrint Set LookAhead = ParsePrint(Entity, Body)
Case kwPut
ParsePut Entity, Body
Case kwRaiseEvent Set LookAhead = ParseRaiseEvent(Entity, Body)
Case kwReDim
ParseReDim Entity, Body
Case kwResume Set LookAhead = ParseResume(Entity, Body)
Case kwReturn
Body.Add , New ReturnConstruct
Case kwRSet Set LookAhead = ParseRSet(Entity, Body)
Case kwSeek Set LookAhead = ParseSeek(Entity, Body)
Case kwSelect
ParseSelect Entity, Body
Case kwSet Set Stmt = Xp.GetStmt(, , Me) Set LookAhead = Xp.LastToken If Stmt Is Nothing Then Fail , Token, Msg094 If Stmt.Kind <> snLet Then Stopp 5
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 Named("InsideProc:=", True), Named("IsStatic:=", True), , acLocal, Entity, Body
Case kwStop
Body.Add , New StopConstruct
Case kwUnlock Set LookAhead = ParseUnlock(Entity, Body)
Case kwWhile
ParseWhile Entity, Body
Case cxWidth Set LookAhead = ParseWidth(Entity, Body)
Case kwWith
ParseWith Entity, Body
Case kwWrite Set LookAhead = ParseWrite(Entity, Body)
Case kwCase, kwElse, kwElseIf, kwLoop, kwNext, kwWend Set LookAhead = Token Exit Do
Case cxName Set LookAhead = ParseName(Entity, Body)
Case Else
MsgBox "Should not happen (2)"
Err.Raise 5 End Select
Case tkIdentifier Select Case Token.Code Case cxLock Set LookAhead = ParseLock(Entity, Body)
Case cxReset
Body.Add , New ResetConstruct
Case cxWidth Set LookAhead = ParseWidth(Entity, Body)
Case Else Set Stmt = Xp.GetStmt(Token, LookAhead, Me) Set LookAhead = Xp.LastToken If Stmt Is Nothing Then Fail , Token, Msg094
Body.Add , Stmt End Select
Case tkDirective Do Set Token = NextToken Loop Until IsBreak(Token)
Case tkOperator Select Case Token.Code Case opWithBang, opWithDot Set Stmt = Xp.GetStmt(Token, LookAhead, Me) Set LookAhead = Xp.LastToken If Stmt Is Nothing Then Fail , Token, Msg094
Body.Add , Stmt
Case Else
MsgBox "Should not happen (3)"
Err.Raise 5 End Select
Case tkHardLineBreak Rem Nothing to do
Case Else
Fail , Token, Msg087 End Select Loop Until IsSingleLine
If LookAhead Is Nothing Then Set ParseBody = NextToken Else Set ParseBody = LookAhead End If End Function
Private Function IsStatement(ByVal Token) Select Case Token.Kind Case tkOperator
IsStatement = Token.Code = opWithBang Or Token.Code = opWithDot
Case tkIdentifier, tkEscapedIdentifier, tkKeyword
IsStatement = True End Select End Function
Private Function ParseClose(ByVal Entity, ByVal Body) Dim Token, Expr
Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Dim Stmt: 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 Entity, ByVal Body) Dim Stmt: Set Stmt = New ContinueConstruct Dim Token: Set Token = NextToken
If Token.Kind <> tkKeyword Then Fail , Token, Msg095
Select Case Token.Code Case kwDo
Stmt.What = cwDo
Case kwFor
Stmt.What = cwFor
Case kwWhile
Stmt.What = cwWhile End Select
Body.Add , Stmt End Sub
Private Sub ParseDo(ByVal Entity, ByVal Body) Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Dim Stmt: Set Stmt = New DoConstruct Dim Token: Set Token = NextToken Dim Mark: Set Mark = Token
If Token.IsKeyword(kwWhile) Then
Stmt.DoType = dtDoWhileLoop Set Stmt.Condition = Xp.GetExpression(, Me) Set Token = Xp.LastToken If Stmt.Condition Is Nothing Then Fail , Mark, Msg065
ElseIf Token.IsKeyword(kwUntil) Then
Stmt.DoType = dtDoUntilLoop Set Stmt.Condition = Xp.GetExpression(, Me) Set Token = Xp.LastToken If Stmt.Condition Is Nothing Then Fail , Mark, Msg065 End If
If Not IsBreak(Token) Then Fail , Token, Msg031 Set Token = ParseBody(, , Entity, Stmt.Body)
If Not Token.IsKeyword(kwLoop) Then Fail , Token, Msg096
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, Msg065
ElseIf Token.IsKeyword(kwUntil) Then
Stmt.DoType = dtDoUntilLoop Set Stmt.Condition = Xp.GetExpression(, Me) Set Token = Xp.LastToken If Stmt.Condition Is Nothing Then Fail , Mark, Msg065 End If End If
If Not IsBreak(Token) Then Fail , Token, Msg031
Body.Add , Stmt End Sub
Private Function ParseErase(ByVal Entity, ByVal Body) Dim Token, Sym
Dim Stmt: Set Stmt = New EraseConstruct
Do Set Token = NextToken If Token.Kind <> tkIdentifier Then Fail Msg003, Token, Msg097
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 Entity, ByVal Body) Dim Stmt: Set Stmt = New ExitConstruct Dim Token: Set Token = NextToken
If Token.IsKeyword(kwDo) Then
Stmt.What = ewDo
ElseIf Token.IsKeyword(kwFor) Then
Stmt.What = ewFor
ElseIf Token.IsKeyword(kwWhile) Then
Stmt.What = ewWhile
ElseIf Token.IsKeyword(kwSub) Then
Stmt.What = ewSub
ElseIf Token.IsKeyword(kwFunction) Then
Stmt.What = ewFunction
ElseIf Token.Kind = tkIdentifier And Token.Code = cxProperty Then
Stmt.What = ewProperty
ElseIf Token.IsKeyword(kwSelect) Then
Stmt.What = ewSelect
Else
Fail , Token, Msg098 End If
Body.Add , Stmt End Sub
Private Function ParseFor(ByVal Entity, ByVal Body) Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Xp.CanHaveTo = True Dim Token: Set Token = NextToken
If Token.IsKeyword(kwEach) Then
ParseForEach Entity, Body Set ParseFor = Nothing Exit Function End If
Dim Stmt: Set Stmt = New ForConstruct If Not IsProperId(, Token) Then Fail Msg003, Token, Msg099
Set Stmt.Counter = New Symbol Set Stmt.Counter.Value = Token
Set Token = NextToken If Not Token.IsOperator(opEq) Then Fail "=", Token, Msg099 Dim Mark: Set Mark = Token
Dim Expr: Set Expr = Xp.GetExpression(, Me) Set Token = Xp.LastToken
If Expr Is Nothing Then Fail , Mark, Msg065 If Expr.Kind <> ekBinaryExpr Then Fail , Mark, Msg065 Dim Bin: Set Bin = Expr If Not Bin.Operator.Value.Code = opTo Then Fail v.To, Token, Msg099
Set Stmt.StartValue = Bin.LHS Set Stmt.EndValue = Bin.RHS
If Token.Kind = tkIdentifier And Token.Code = 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 Msg100, Mark, Msg099 Else Dim Lit: Set Lit = New Literal Set Lit.Value = New Token
Lit.Value.Kind = tkIntegerNumber
Lit.Value.Text = "1" Set Stmt.Increment = Lit End If
If Not IsBreak(Token) Then Fail , Token, Msg031 Set Token = ParseBody(, , Entity, Stmt.Body)
If Token.IsKeyword(kwNext) Then Set Token = NextToken
If IsProperId(, Token) And Token.Code = Stmt.Counter.Value.Code Then 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, Msg031 End If
ElseIf IsBreak(Token) Then Rem OK
Else
Fail , Token, Msg031 End If
Else
Fail , Token, Msg101 End If
Body.Add , Stmt Set ParseFor = Token End Function
Private Sub ParseForEach(ByVal Entity, ByVal Body) Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Dim Stmt: Set Stmt = New ForEachConstruct Dim Token: Set Token = NextToken If Not IsProperId(, Token) Then Fail Msg103, Token, Msg102
Set Stmt.Element = New Symbol Set Stmt.Element.Value = Token
Set Token = NextToken If Not Token.IsKeyword(kwIn) Then Fail v.In, Token, Msg102
Set Token = NextToken If Not IsProperId(, Token) Then Fail Msg104, Token, Msg102 Set Stmt.Group = Xp.GetStmt(Token, , Me) If Stmt.Group Is Nothing Then Fail Msg104, Token, Msg102
Set Token = Xp.LastToken If Not IsBreak(Token) Then Fail , Token, Msg031
Set Token = ParseBody(, , Entity, Stmt.Body) If Not Token.IsKeyword(kwNext) Then Fail , Token, Msg101
MustEatLineBreak
Body.Add , Stmt End Sub
Private Sub ParseGet(ByVal Entity, ByVal Body) Dim Stmt: Set Stmt = New GetConstruct Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(, Me) Dim Token: Set Token = Xp.LastToken
If Stmt.FileNumber Is Nothing Then Fail Msg110, Token, Msg105 If Token.Kind <> tkListSeparator Then Fail ",", Token, Msg105
Set Stmt.RecNumber = Xp.GetExpression(, Me) Set Token = Xp.LastToken Rem RecNumber can be nothing If Token.Kind <> tkListSeparator Then Fail ",", Token, Msg105
Set Token = NextToken If Not IsProperId(Named("CanHaveSuffix:=", True), Token) Then Fail Msg103, Token, Msg105
Set Stmt.Var = New Symbol Set Stmt.Var.Value = Token
Body.Add , Stmt End Sub
Private Sub ParseGoSub(ByVal Entity, ByVal Body) Dim Stmt: Set Stmt = New GoSubConstruct Dim Token: Set Token = NextToken
If IsProperId(, Token) Then Dim Label: Set Label = New LabelConstruct Set Label.Id = NewId(Token)
Set Stmt.Target = Label
ElseIf Token.Kind = tkLineContinuation Then Dim LinNum: Set LinNum = New LineNumberConstruct Set LinNum.Value = Token
Set Stmt.Target = LinNum Else
Fail , Token, Msg108 End If
Body.Add , Stmt End Sub
Private Sub ParseGoTo(ByVal Entity, ByVal Body) Dim Stmt: Set Stmt = New GoToConstruct Dim Token: Set Token = NextToken
Select Case Token.Kind Case tkIdentifier Dim Label: Set Label = New LabelConstruct Set Label.Id = NewId(Token) Set Stmt.Target = Label
Case tkIntegerNumber Dim LinNum: Set LinNum = New LineNumberConstruct Set LinNum.Value = Token
Set Stmt.Target = LinNum
Case Else
Fail , Token, Msg108 End Select
Body.Add , Stmt End Sub
Private Function ParseIf(ByVal Entity, ByVal Body) Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Dim Stmt: Set Stmt = New IfConstruct
Dim Arm: Set Arm = New IfArm Rem If <condition> ? Dim Token: Set Token = NextToken Set Arm.Condition = Xp.GetExpression(Token, Me) If Arm.Condition Is Nothing Then Fail , Token, Msg065
Rem If <condition> Then ? Set Token = Xp.LastToken If Not Token.IsKeyword(kwThen) Then Fail v.Then, Token, Msg088
Stmt.Arms.Add , Arm Set Token = NextToken
If Token.Kind = tkSoftLineBreak Then Set Token = Nothing
SubGoTo2 Token, Entity, Arm, Stmt
ElseIf IsHardBreak(Token) Then Set Token = ParseBody(, , Entity, Arm.Body) If Token.Kind <> tkKeyword Then Fail , Token, Msg089
Do Select Case Token.Code Case kwElseIf Set Arm = New IfArm Set Arm.Condition = Xp.GetExpression(, Me) If Arm.Condition Is Nothing Then Fail , Token, Msg065
Set Token = Xp.LastToken If Not Token.IsKeyword(kwThen) Then Fail v.Then, Token, Msg088
Set Token = ParseBody(, , Entity, Arm.Body)
Stmt.Arms.Add , Arm
Case kwElse Set Token = NextToken If Not IsHardBreak(Token) Then Fail , Token, Msg027
Set Token = ParseBody(, , Entity, Stmt.ElseBody)
If Token.IsKeyword(kwIf) Then Set Token = NextToken Exit Do End If
Fail , Token, Msg085 & v.If
Case kwIf Set Token = NextToken Exit Do
Case Else
Fail , Token, Msg089 End Select Loop
ElseIf IsStatement(Token) Then
SubGoTo2 Token, Entity, Arm, Stmt
Else
Fail , Token, Msg090 End If
Body.Add , Stmt Set ParseIf = Token End Function
Private Sub SubGoTo2(ByRef Token, ByVal Entity, ByVal Arm, ByVal Stmt) Do If Token Is Nothing Then Set Token = NextToken If IsHardBreak(Token) Then Exit Do End If
If Not IsStatement(Token) Then Fail , Token, Msg087
Rem If <condition> Then : <statement> Set Token = ParseBody(Named("IsSingleLine:=", True), Named("LookAhead:=", Token), Entity, Arm.Body) If Token.Kind <> tkSoftLineBreak Then Exit Do Set Token = Nothing Loop
If Token.IsKeyword(kwElse) Then Rem If <condition> Then : <statement> Else Set Token = NextToken
Do If Token.Kind = tkSoftLineBreak Then Set Token = NextToken If Not IsStatement(Token) Then Fail , Token, Msg087
Set Token = ParseBody(Named("IsSingleLine:=", True), Named("LookAhead:=", Token), Entity, Stmt.ElseBody) Loop While Token.Kind = tkSoftLineBreak End If
If Not IsHardBreak(Token) Then Fail , Token, Msg031 End Sub
Private Function ParseInput(ByVal Entity, ByVal Body) Dim Sym
Dim Stmt: Set Stmt = New InputConstruct Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(, Me) Dim Token: Set Token = Xp.LastToken If Token.Kind <> tkListSeparator Then Fail ",", Token, Msg109
Do Set Token = NextToken If Not IsProperId(Named("CanHaveSuffix:=", True), Token) Then Fail Msg103, Token, Msg109
Set Sym = New Symbol Set Sym.Value = NewId(Token)
Stmt.Vars.Add , Sym
Set Token = NextToken Loop While Token.Kind = tkListSeparator
Body.Add , Stmt Set ParseInput = Token End Function
Private Function ParseLock(ByVal Entity, ByVal Body) Dim Stmt: Set Stmt = New LockConstruct Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(, Me) If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg112
If Xp.LastToken.Kind = tkListSeparator Then
Xp.CanHaveTo = True Set Stmt.RecordRange = Xp.GetExpression(, Me) If Stmt.RecordRange Is Nothing Then Fail Msg113, Xp.LastToken, Msg112 End If
Body.Add , Stmt Set ParseLock = Xp.LastToken End Function
Private Function ParseLSet(ByVal Entity, ByVal Body) Dim Xp: Set Xp = New Expressionist Dim Stmt: Set Stmt = New LSetConstruct
Dim ISt: Set ISt = Xp.GetStmt(, , Me) If ISt.Kind <> snLet Then Stopp 6
Dim Asg: Set Asg = ISt If Asg.Name.Kind <> ekSymbol Then Stopp 7 If Asg.Operator.Value.Code <> opEq Then Fail , Asg.Operator.Value, Msg114
Set Stmt.Name = Asg.Name Set Stmt.Value = Asg.Value
Body.Add , Stmt End Function
Private Function ParseName(ByVal Entity, ByVal Body) Dim Stmt: Set Stmt = New NameConstruct Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.OldPathName = Xp.GetExpression(, Me) If Stmt.OldPathName Is Nothing Then Fail Msg116, Xp.LastToken, Msg115 If Xp.LastToken.IsKeyword(kwAs) Then Fail v.As, Xp.LastToken, Msg115
Set Stmt.NewPathName = Xp.GetExpression(, Me) If Stmt.NewPathName Is Nothing Then Fail Msg117, Xp.LastToken, Msg115
Body.Add , Stmt Set ParseName = Xp.LastToken End Function
Private Function ParseOn(ByVal Entity, ByVal Body) Dim WentTo, Label, OnStmt, Comp, LinNum
Dim Xp: Set Xp = New Expressionist Dim Token: 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 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, Msg105 End Select
ElseIf Token.IsKeyword(kwResume) Then Set Token = NextToken If Not Token.IsKeyword(kwNext) Then Fail Token, Msg103
Dim ResStmt: Set ResStmt = New ResumeConstruct
ResStmt.IsNext = True Set OnStmt.Statement = ResStmt
Else
Fail Token, Msg110 End If
Set Token = NextToken
Body.Add , OnStmt
Else Set Comp = New OnComputedConstruct
Xp.FullMode = True
Set Comp.Value = Xp.GetExpression(Token, Me) Set Token = Xp.LastToken If Comp.Value Is Nothing Then Fail Token, Msg065
If Token.IsKeyword(kwGoTo) Then
Comp.IsGoTo = True
ElseIf Token.IsKeyword(kwGoSub) Then Rem Comp.IsGoTo = False
Else
Fail Token, Msg110 End If
Do Set Token = NextToken
Select Case Token.Kind Case tkIntegerNumber 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 Entity, ByVal Body) Dim Stmt: Set Stmt = New OpenConstruct Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.PathName = Xp.GetExpression(, Me) If Stmt.PathName Is Nothing Then Fail Msg120, Xp.LastToken, Msg119 If Not Xp.LastToken.IsKeyword(kwFor) Then Fail v.For, Xp.LastToken, Msg119
Dim Token: Set Token = NextToken If Token.Kind <> tkKeyword Then Fail , Token, Msg030
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, Msg030 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, Msg075 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 v.As, Token, Msg119 Set Stmt.FileNumber = Xp.GetExpression(, Me) If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg119 Set Token = Xp.LastToken
If Token.IsKeyword(cxLen) Then Set Token = NextToken If Not Token.IsOperator(opEq) Then Fail "=", Token, Msg119
Set Stmt.Length = Xp.GetExpression(, Me) Set Token = Xp.LastToken End If
Body.Add , Stmt Set ParseOpen = Token End Function
Private Function ParsePrint(ByVal Entity, ByVal Body) Dim Sym
Dim Stmt: Set Stmt = New PrintConstruct Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(, Me) Dim Token: Set Token = Xp.LastToken If Stmt.FileNumber Is Nothing Then Fail Msg110, Token, Msg121 If Token.Kind <> tkListSeparator Then Fail ",", Token, Msg121 Set Token = Nothing
Do Dim Expr: Set Expr = Xp.GetExpression(Token, Me) Set Token = Xp.LastToken If Expr Is Nothing Then Fail Msg103, Xp.LastToken, Msg121
Dim Arg: Set Arg = New PrintArg
If Expr.Kind = ekIndexer Then Dim Exec: Set Exec = Expr
If Exec.LHS.Kind = ekSymbol Then Set Sym = Exec.LHS
If Sym.Value.Kind = tkIdentifier And Sym.Value.Code = cxSpc Then If Exec.Arguments.Count > 1 Then Stopp 14 Set Arg.Indent = New PrintIndent Set Arg.Indent.Value = Exec.Arguments(1) Set Expr = Xp.GetExpression(Token, Me) Set Token = Xp.LastToken
ElseIf Sym.Value.Kind = tkIdentifier And Sym.Value.Code = cxTab Then If Exec.Arguments.Count > 1 Then Stopp 15 Set Arg.Indent = New PrintIndent
Arg.Indent.IsTab = True Set Arg.Indent.Value = Exec.Arguments(1) Set Expr = Xp.GetExpression(Token, Me) Set Token = Xp.LastToken End If End If
ElseIf Expr.Kind = ekSymbol Then Set Sym = Expr
If Sym.Value.Kind = tkIdentifier And Sym.Value.Code = cxTab Then Set Arg.Indent = New PrintIndent
Arg.Indent.IsTab = True Set Expr = Xp.GetExpression(Token, Me) Set Token = Xp.LastToken End If End If
Set Arg.Value = Expr
If Token.Kind = tkPrintSeparator Then
Arg.HasSemicolon = True Set Token = NextToken End If
Stmt.Output.Add , Arg Loop Until IsEndOfContext(Token)
Body.Add , Stmt Set ParsePrint = Token End Function
Private Sub ParsePut(ByVal Entity, ByVal Body) Dim Stmt: Set Stmt = New PutConstruct Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(, Me) Dim Token: Set Token = Xp.LastToken
If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg107 If Token.Kind <> tkListSeparator Then Fail ",", Xp.LastToken, Msg107
Set Stmt.RecNumber = Xp.GetExpression(, Me) Set Token = Xp.LastToken Rem RecNumber can be nothing If Token.Kind <> tkListSeparator Then Fail ",", Xp.LastToken, Msg107
Set Token = NextToken If Not IsProperId(Named("CanHaveSuffix:=", True), Token) Then Fail Msg003, Token, Msg107
Set Stmt.Var = New Symbol Set Stmt.Var.Value = Token
Body.Add , Stmt End Sub
Private Function ParseRaiseEvent(ByVal Entity, ByVal Body) Dim Stmt: Set Stmt = New RaiseEventConstruct Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Dim ISt: Set ISt = Xp.GetStmt(, , Me) Dim Token: Set Token = Xp.LastToken If ISt.Kind <> snCall Then Stopp 16
Dim Exec: Set Exec = ISt If Exec.LHS.Kind <> ekSymbol Then Stopp 17
Dim Sym: 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 Entity, ByVal Body) Dim Var
Dim Stmt: Set Stmt = New ReDimConstruct Dim Token: Set Token = NextToken
If Token.IsKeyword(kwPreserve) Then
Stmt.HasPreserve = True Set Token = NextToken End If
For Each Var In Stmt.Vars.NewEnum If Var.HasNew Then Fail , Var.Id.Name, Msg062 If Not Var.Init Is Nothing Then Stopp 18 If Var.Subscripts.Count = 0 Then Fail , Var.Id.Name, Msg122 Next
Body.Add , Stmt End Sub
Private Function ParseResume(ByVal Entity, ByVal Body) Dim LinNum
Dim Stmt: Set Stmt = New ResumeConstruct Dim Token: Set Token = NextToken
Select Case Token.Kind Case tkIntegerNumber Set LinNum = New LineNumberConstruct Set LinNum.Value = Token Set Stmt.Target = LinNum Set Token = NextToken
Case tkIdentifier Dim Label: 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, Msg101
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" 'TODO: It can be fooled Set Stmt.Target = LinNum End Select
Body.Add , Stmt Set ParseResume = Token End Function
Private Sub ParseSelect(ByVal Entity, ByVal Body) Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True Dim Stmt: Set Stmt = New SelectConstruct
Dim Token: Set Token = NextToken If Not Token.IsKeyword(kwCase) Then Fail v.Case, Token, Msg091
Set Stmt.Value = Xp.GetExpression(, Me) Set Token = Xp.LastToken If Stmt.Value Is Nothing Then Fail , Token, Msg065 If Not IsBreak(Token) Then Fail , Token, Msg031
Rem From now on we'll accept the "To" operator
Xp.CanHaveTo = True
Do Rem We can have a "look-ahead" token Case from ParseBody below. Rem After parsing the statement block it may have stumbled upon "Case Else", for instance. If Not Token.IsKeyword(kwCase) Then Set Token = SkipLineBreaks
Rem We will have this situation if there's an empty Select Case like: Rem Select Case Abc Rem End Select If Token.IsKeyword(kwEnd) Then Set Token = NextToken If Token.IsKeyword(kwSelect) Then Exit Do
Fail , Token, Msg085 & v.Select End If
Dim Cs: Set Cs = New CaseConstruct
Do Dim Expr: 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 Dim IsExpr: Set IsExpr = New BinaryExpression 'IsExpr.LHS will be Nothing
Set Token = NextToken If Token.Kind <> tkOperator Then Fail , Token, Msg092
Set IsExpr.Operator = NewOperator(Token) If IsExpr.Operator.IsUnary Then Fail , Token, Msg092
Set IsExpr.RHS = Xp.GetExpression(, Me) Set Token = Xp.LastToken If IsExpr.RHS Is Nothing Then Fail , Token, Msg065
Set Expr = IsExpr
ElseIf Token.IsKeyword(kwElse) Then Rem We have a "Case Else". Set Token = ParseBody(, , Entity, Stmt.CaseElse) If Not Token.IsKeyword(kwSelect) Then Fail , Token, Msg085 & v.Select
Rem Cs must not be added after Loop Set Cs = Nothing Exit Do
Else
Fail , Token, Msg093 End If End If
Cs.Conditions.Add , Expr
If IsBreak(Token) Then Set Token = ParseBody(, , Entity, Cs.Body) Exit Do End If
If Token.Kind <> tkListSeparator Then Fail , Token, Msg027 Loop
If Not Cs Is Nothing Then Stmt.Cases.Add , Cs Loop Until Token.IsKeyword(kwSelect)
Body.Add , Stmt End Sub
Private Function ParseRSet(ByVal Entity, ByVal Body) Dim Xp: Set Xp = New Expressionist Dim Stmt: Set Stmt = New RSetConstruct
Dim ISt: Set ISt = Xp.GetStmt(, , Me) If ISt.Kind <> snLet Then Stopp 19
Dim Asg: Set Asg = ISt If Asg.Name.Kind <> ekSymbol Then Stopp 20 If Asg.Operator.Value.Code <> opEq Then Fail , Asg.Operator.Value
Set Stmt.Name = Asg.Name Set Stmt.Value = Asg.Value
Body.Add , Stmt End Function
Private Function ParseSeek(ByVal Entity, ByVal Body) Dim Stmt: Set Stmt = New SeekConstruct Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(, Me) If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg123 If Xp.LastToken.Kind <> tkListSeparator Then Fail ",", Xp.LastToken, Msg123
Set Stmt.Position = Xp.GetExpression(, Me) If Stmt.Position Is Nothing Then Fail , Xp.LastToken, Msg124
Body.Add , Stmt Set ParseSeek = Xp.LastToken End Function
Private Function ParseUnlock(ByVal Entity, ByVal Body) Dim Stmt: Set Stmt = New UnlockConstruct Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(, Me) If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg125
If Xp.LastToken.Kind = tkListSeparator Then
Xp.CanHaveTo = True Set Stmt.RecordRange = Xp.GetExpression(, Me) If Stmt.RecordRange Is Nothing Then Fail Msg113, Xp.LastToken, Msg125 End If
Body.Add , Stmt Set ParseUnlock = Xp.LastToken End Function
Private Sub ParseWhile(ByVal Entity, ByVal Body) Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True Dim Stmt: Set Stmt = New WhileConstruct
Set Stmt.Condition = Xp.GetExpression(, Me) Dim Token: Set Token = Xp.LastToken If Stmt.Condition Is Nothing Then Fail , Token, Msg065
If Not IsBreak(Token) Then Fail , Token, Msg031 Set Token = ParseBody(, , Entity, Stmt.Body)
If Token.IsKeyword(kwWend) Then Rem OK
ElseIf Token.IsKeyword(kwWhile) Then Rem OK
Else
Fail , Token, Msg127 End If
MustEatLineBreak
Body.Add , Stmt End Sub
Private Function ParseWidth(ByVal Entity, ByVal Body) Dim Stmt: Set Stmt = New WidthConstruct Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(, Me) If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg128 If Xp.LastToken.Kind <> tkListSeparator Then Fail ",", Xp.LastToken, Msg128
Xp.CanHaveTo = True Set Stmt.Value = Xp.GetExpression(, Me) If Stmt.Value Is Nothing Then Fail Msg129, Xp.LastToken, Msg128
Body.Add , Stmt Set ParseWidth = Xp.LastToken End Function
Private Sub ParseWith(ByVal Entity, ByVal Body) Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True Dim Stmt: Set Stmt = New WithConstruct
Dim Token: Set Token = NextToken If Not IsProperId(, Token) Then Fail Msg131, Token, Msg130
Set Stmt.PinObject = Xp.GetStmt(Token, , Me) Set Token = Xp.LastToken If Stmt.PinObject Is Nothing Then Fail Msg131, Token, Msg130
Set Token = ParseBody(, Named("LookAhead:=", Token), Entity, Stmt.Body) If Not Token.IsKeyword(kwWith) Then Fail , Token, Msg132
Body.Add , Stmt End Sub
Private Function ParseWrite(ByVal Entity, ByVal Body) Dim Stmt: Set Stmt = New WriteConstruct Dim Xp: Set Xp = New Expressionist
Xp.FullMode = True
Set Stmt.FileNumber = Xp.GetExpression(, Me) Dim Token: Set Token = Xp.LastToken If Stmt.FileNumber Is Nothing Then Fail Msg110, Xp.LastToken, Msg133 If Token.Kind <> tkListSeparator Then Fail ",", Xp.LastToken, Msg133
Do Dim Expr: 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, ByVal RightParm) If LeftParm.IsArray <> RightParm.IsArray Then Exit Function If LeftParm.IsByVal <> RightParm.IsByVal Then Exit Function If LeftParm.IsOptional <> RightParm.IsOptional Then Exit Function If LeftParm.IsParamArray <> RightParm.IsParamArray Then Exit Function If LeftParm.DataType.Id.Name.Code <> RightParm.DataType.Id.Name.Code Then Exit Function
AreEqual = True End Function
Private Function SynthLower(ByVal Entity) Dim Token: Set Token = New Token
Token.Kind = tkIntegerNumber
Token.Text = CStr(Entity.OptionBase)
Dim Lit: Set Lit = New Literal Set Lit.Value = Token
Set SynthLower = Lit End Function
Private Sub MustEatLineBreak() Dim Token: Set Token = NextToken If IsBreak(Token) Then Exit Sub If Token.Kind = tkComment Then Exit Sub
Fail Msg031, Token, Msg005 End Sub
Private Function SkipLineBreaks() Dim Token
Do Set Token = NextToken Loop While Token.Kind = tkSoftLineBreak Or Token.Kind = tkHardLineBreak Or Token.Kind = tkComment
Set SkipLineBreaks = Token End Function
Private Function IsId(ByVal CanHaveSuffix, ByVal Token) If IsMissing(CanHaveSuffix) Then CanHaveSuffix = False If Not CanHaveSuffix And Token.Suffix <> vbNullChar Then Fail , Token, Msg060
IsId = Token.Kind = tkIdentifier Or Token.Kind = tkEscapedIdentifier End Function
Dim Pos If IsMissing(CanHaveSuffix) Then CanHaveSuffix = False If Not CanHaveSuffix And Token.Suffix <> vbNullChar Then Fail , Token, Msg060
If Token.Kind = tkIdentifier Then
IsProperId = True Exit Function End If
If Token.Kind <> tkEscapedIdentifier Then Exit Function Dim Text: Text = NameBank_(Token)
For Pos = 1 To Len(Text) Dim Cp: Cp = AscW(Mid(Text, Pos, 1)) Dim IsOK: IsOK = Cp = ASCII_US If Not IsOK Then IsOK = Cp >= ASCII_ZERO And Cp <= ASCII_NINE If Not IsOK Then IsOK = IsLetter(Cp) If Not IsOK Then IsOK = IsSurrogate(Cp) If Not IsOK Then Exit Function Next
IsProperId = True End Function
Public Function IsHardBreak(ByVal Token)
IsHardBreak = Token.Kind = tkHardLineBreak Or Token.Kind = tkComment End Function
Public Function IsBreak(ByVal Token)
IsBreak = Token.Kind = tkSoftLineBreak Or Token.Kind = tkHardLineBreak Or Token.Kind = tkComment Or Token.Kind = tkEndOfStream End Function
Private Function IsProperDataType(ByVal Token) If Token.Suffix <> vbNullChar Then Fail , Token, Msg060
Select Case Token.Kind Case tkIdentifier
IsProperDataType = True
Case tkEscapedIdentifier
IsProperDataType = IsProperId(, Token)
Case tkKeyword
IsProperDataType = IsBuiltinDataType(Token) End Select End Function
Private Function IsConstDataType(ByVal Token) 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) Select Case Token.Code Case cxObject, kwVariant
IsBuiltinDataType = True
Case Else
IsBuiltinDataType = IsConstDataType(Token) End Select End Function
Private Function IsDataType(ByVal Token) If Token.Suffix <> vbNullChar Then Fail , Token, Msg060
If Token.IsKeyword(kwAny) Then
IsDataType = True Exit Function End If
IsDataType = IsProperDataType(Token) End Function
Private Function IsEndOfContext(ByVal Token) Dim Result: Result = IsBreak(Token) If Not Result Then Result = Token.Kind = tkRightParenthesis If Not Result Then Result = Token.Kind = tkListSeparator If Not Result Then Result = Token.Kind = tkPrintSeparator
If Not Result And Token.Kind = tkKeyword Then
Result = Token.Code = kwThen If Not Result Then Result = Token.Code = kwElse End If
If Not Result Then Result = Token.Kind = tkIdentifier And Token.Code = cxStep
IsEndOfContext = Result End Function
Public Sub Fail(ByVal Expected, ByVal Token, ByVal Message) Dim Ch, Msg, Got, Text
If IsMissing(Expected) Then Expected = ""
Select Case Token.Kind Case tkEscapedIdentifier
Got = "[" & NameBank_(Token) & "]"
Case tkFileHandle, tkDirective
Got = "#" & NameBank_(Token)
Private Function FromChar(ByVal TypeDeclarationChar) Dim 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
MsgBox "Should not happen (4)"
Err.Raise 5 End Select
Set FromChar = NewDataType(Token) End Function
Private Sub CheckDupl(ByVal JumpProp, ByVal Entity, ByVal Token) If IsMissing(JumpProp) Then JumpProp = False Dim Name: Name = NameBank_(Token)
With Entity If .Consts.Exists(Name) Then Fail , Token, Msg006 & Name If .Enums.Exists(Name) Then Fail , Token, Msg006 & Name If .Declares.Exists(Name) Then Fail , Token, Msg006 & Name If .Events.Exists(Name) Then Fail , Token, Msg006 & Name If .Impls.Exists(Name) Then Fail , Token, Msg006 & Name If .Vars.Exists(Name) Then Fail , Token, Msg006 & Name If .Types.Exists(Name) Then Fail , Token, Msg006 & Name If .Subs.Exists(Name) Then Fail , Token, Msg006 & Name If .Functions.Exists(Name) Then Fail , Token, Msg006 & Name If Not JumpProp Then If .Properties.Exists(Name) Then Fail , Token, Msg006 & Name End With End Sub End Class
Class PrintArg Public Indent Public Value Public HasSemicolon
Private Sub Class_Initialize() Set Indent = Nothing Set Value = Nothing End Sub End Class
Class PrintConstruct Public Output Public FileNumber
Private Sub Class_Initialize() Set Output = New KeyedList Set FileNumber = Nothing End Sub
Public Property Get Kind()
Kind = snPrint End Property End Class
Class PrintIndent Public IsTab Public Value
Private Sub Class_Initialize() Set Value = Nothing End Sub End Class
Class PropertyConstruct Public Parameters Public Body Public Access Public IsStatic Public IsDefault
Private Sub Class_Initialize() Set Parameters = New KeyedList
Parameters.CompareMode = vbTextCompare
Set Body = New KeyedList End Sub End Class
Class PropertySlot Private PropertyGet_ Private PropertyLet_ Private PropertySet_
Public Id Public DataType
Private Sub Class_Initialize() Set PropertyGet_ = Nothing Set PropertyLet_ = Nothing Set PropertySet_ = Nothing Set Id = Nothing Set DataType = Nothing End Sub
Public Sub Add(ByVal Kind, ByVal Item) Select Case Kind Case VbGet If Not PropertyGet_ Is Nothing Then Err.Raise 457 Set PropertyGet_ = Item
Case VbLet If Not PropertyLet_ Is Nothing Then Err.Raise 457 Set PropertyLet_ = Item
Case VbSet If Not PropertySet_ Is Nothing Then Err.Raise 457 Set PropertySet_ = Item
Case Else
MsgBox "Should not happen (5)"
Err.Raise 5 End Select End Sub
Public Default Property Get Item(ByVal Kind) Select Case Kind Case VbGet Set Item = PropertyGet_
Case VbLet Set Item = PropertyLet_
Case VbSet Set Item = PropertySet_
Case Else
MsgBox "Should not happen (6)"
Err.Raise 5 End Select End Property
Public Property Get Exists(ByVal Kind) 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
MsgBox "Should not happen (7)"
Err.Raise 5 End Select End Property End Class
Class PutConstruct Public FileNumber Public RecNumber Public Var
Private Sub Class_Initialize() Set FileNumber = Nothing Set RecNumber = Nothing Set Var = Nothing End Sub
Public Property Get Kind()
Kind = snPut End Property End Class
Class RaiseEventConstruct Public Arguments Public Id
Private Sub Class_Initialize() Set Arguments = New KeyedList Set Id = Nothing End Sub
Public Property Get Kind()
Kind = snRaiseEvent End Property End Class
Class ReDimConstruct Public Vars Public HasPreserve
Private Sub Class_Initialize() Set Vars = New KeyedList End Sub
Public Property Get Kind()
Kind = snReDim End Property End Class
Class ResetConstruct Public Property Get Kind()
Kind = snReset End Property End Class
Class ResumeConstruct Public IsNext Public Target
Private Sub Class_Initialize() Set Target = Nothing End Sub
Public Property Get Kind()
Kind = snResume End Property End Class
Class ReturnConstruct Public Property Get Kind()
Kind = snReturn End Property End Class
Class Reverter Public Builder
Public Sub Transpile(ByVal Source) Dim Idx, Ent
For Idx = 1 To Source.Entities.Count Set Ent = Source.Entities(Idx)
EmitEntity Ent If Idx <> Source.Entities.Count Then Builder.AppendLn "" Next End Sub
Private Sub EmitEntity(ByVal Entity) Dim Sep, Count
Dim Def: Set Def = Nothing Dim Var: Set Var = Nothing Dim Slt: Set Slt = Nothing Dim Prc: Set Prc = Nothing Dim Typ: Set Typ = Nothing Dim Enm: Set Enm = Nothing Dim Evt: Set Evt = Nothing Dim Cnt: Set Cnt = Nothing Dim Dcl: Set Dcl = Nothing Dim Fnc: Set Fnc = Nothing Dim Prp: Set Prp = Nothing Dim Ipl: Set Ipl = Nothing
If Entity.OptionExplicit Then .AppendLn "Option Explicit"
.AppendLn ""
For Each Ipl In Entity.Impls.NewEnum
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.NewEnum
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.NewEnum
EmitType Typ
.AppendLn ""
Count = Count + 1 If Count <> Entity.Types.Count Then .AppendLn ""
Sep = True Next
If Sep And Entity.Vars.Count > 0 Then
.AppendLn ""
Sep = False End If
For Each Var In Entity.Vars.NewEnum
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.NewEnum
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.NewEnum
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.NewEnum
EmitEnum Enm
.AppendLn ""
Count = Count + 1 If Count <> Entity.Enums.Count Then .AppendLn ""
Sep = True Next
If Sep And Entity.Functions.Count > 0 Then
.AppendLn ""
Sep = False End If
Count = 0
For Each Fnc In Entity.Functions.NewEnum
EmitAccess Fnc.Access If Fnc.IsStatic Then .Append "Static " If Fnc.IsDefault Then .Append "Default " If Fnc.IsIterator Then .Append "Iterator "
.Append "Function "
EmitId Fnc.Id
EmitParams Fnc.Parameters
.Append " As "
EmitDataType Fnc.DataType
.AppendLn ""
.Indent
EmitBody Fnc.Body
.Deindent
.AppendLn "End Function"
Count = Count + 1 If Count <> Entity.Functions.Count Then .AppendLn ""
Sep = True Next
If Sep And Entity.Subs.Count > 0 Then
.AppendLn ""
Sep = False End If
Count = 0
For Each Prc In Entity.Subs.NewEnum
EmitAccess Prc.Access If Prc.IsStatic Then .Append "Static " If Prc.IsDefault Then .Append "Default "
.Append "Sub "
EmitId Prc.Id
EmitParams Prc.Parameters
.AppendLn ""
.Indent
EmitBody Prc.Body
.Deindent
.AppendLn "End Sub"
Sep = True
Count = Count + 1 If Count <> Entity.Subs.Count Then .AppendLn "" Next
If Sep And Entity.Properties.Count > 0 Then
.AppendLn ""
Sep = False End If
Count = 0
For Each Slt In Entity.Properties.NewEnum 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 ""
For Each Mem In Enm.Enumerands.NewEnum
EmitId Mem.Id
If Not Mem.Value Is Nothing Then
Builder.Append " = "
EmitExpression , Mem.Value End If
Builder.AppendLn "" Next
Builder.Deindent
Builder.Append "End Enum" End Sub
Private Sub EmitExpression(ByVal Op, ByVal Expr) Dim Par, Idx
If IsMissing(Op) Then Set Op = Nothing Dim Sym: Set Sym = Nothing Dim Lit: Set Lit = Nothing Dim Hnd: Set Hnd = Nothing Dim Exr: Set Exr = Nothing Dim Tup: Set Tup = Nothing Dim Uni: Set Uni = Nothing Dim Bin: Set Bin = Nothing
Select Case Expr.Kind Case ekLiteral Set Lit = Expr
EmitToken Lit.Value
Case ekSymbol Set Sym = Expr
EmitToken Sym.Value
Case ekFileHandle Set Hnd = Expr
Builder.Append "#"
EmitToken Hnd.Value
Case ekTuple Set Tup = Expr
For Idx = 1 To Tup.Elements.Count Set Exr = Tup.Elements(Idx)
EmitExpression , Exr If Idx <> Tup.Elements.Count Then Builder.Append ", " Next
Case ekUnaryExpr Set Uni = Expr
EmitOperator Uni.Operator
EmitExpression , Uni.Value
Case ekBinaryExpr Set Bin = Expr If Not Op Is Nothing Then Par = ComparePrecedence(Op, Bin.Operator) = 1 If Par Then Builder.Append "("
For Each Stmt In Body.NewEnum
EmitStmt Stmt
Builder.AppendLn "" Next End Sub
Private Sub EmitStmt(ByVal Stmt) 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) Dim Count, Expr
EmitExpression , Stmt.LHS
If Stmt.Arguments.Count > 0 Then
Builder.Append "("
For Each Expr In Stmt.Arguments.NewEnum
EmitExpression , Expr
Count = Count + 1 If Count <> Stmt.Arguments.Count Then Builder.Append ", " Next
Builder.Append ")" End If End Sub
Private Sub EmitClose(ByVal Stmt) Dim Number
Builder.Append "Close"
For Each Number In Stmt.FileNumbers.NewEnum
Builder.Append " "
EmitExpression , Number Next End Sub
Private Sub EmitContinue(ByVal Stmt)
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)
Stopp 21 End Sub
Private Sub EmitDim(ByVal Stmt) 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 Not Stmt.Init Is Nothing Then
Builder.Append " = "
EmitExpression , Stmt.Init End If
If Stmt.Access = acLocal Then Builder.Indent End Sub
Private Sub EmitDo(ByVal Stmt)
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)
Builder.Append "End" End Sub
Private Sub EmitErase(ByVal Stmt) Dim Count, Var
Builder.Append "Erase "
For Each Var In Stmt.Vars.NewEnum
EmitId Var.Id
Count = Count + 1 If Count <> Stmt.Vars.Count Then Builder.Append ", " Next
Builder.Append " " End Sub
Private Sub EmitExit(ByVal Stmt)
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
If Stmt.Increment.Kind = ekLiteral Then: Set Lit = Stmt.Increment: HasStep = Lit.Value.Line <> 0 Or Lit.Value.Column <> 0
If HasStep Then
Builder.Append " Step "
EmitExpression , Stmt.Increment End If
Builder.AppendLn ""
Builder.Indent
EmitBody Stmt.Body
Builder.Deindent
Builder.Append "Next" End Sub
Private Sub EmitForEach(ByVal Stmt)
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)
Builder.Append "Get "
EmitExpression , Stmt.FileNumber
Builder.Append ", " If Not Stmt.RecNumber Is Nothing Then EmitExpression , Stmt.RecNumber
Builder.Append ", "
EmitToken Stmt.Var.Value End Sub
Private Sub EmitGoSub(ByVal Stmt)
Builder.Append "GoSub "
If Stmt.Target.Kind = snLineNumber Then Dim LinNum: Set LinNum = Stmt.Target
EmitToken LinNum.Value Else Dim Label: Set Label = Stmt.Target
EmitId Label.Id End If End Sub
Private Sub EmitGoTo(ByVal Stmt)
Builder.Append "GoTo "
If Stmt.Target.Kind = snLineNumber Then Dim LinNum: Set LinNum = Stmt.Target
EmitToken LinNum.Value Else Dim Label: Set Label = Stmt.Target
EmitId Label.Id End If End Sub
Private Sub EmitIf(ByVal Stmt) Dim Arm, Idx
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
For Each Var In Stmt.Vars.NewEnum
EmitToken Var.Value
Count = Count + 1 If Count <> Stmt.Vars.Count Then Builder.Append ", " Next End Sub
Private Sub EmitLabel(ByVal Stmt)
Builder.Append NameBank_(Stmt.Id.Name)
Builder.Append ": " End Sub
Private Sub EmitLet(ByVal Stmt)
EmitExpression , Stmt.Name
EmitOperator Stmt.Operator
EmitExpression , Stmt.Value End Sub
Private Sub EmitLineNumber(ByVal Stmt)
EmitToken Stmt.Value End Sub
Private Sub EmitLock(ByVal Stmt)
Builder.Append "Lock "
EmitExpression , Stmt.FileNumber
Builder.Append ", "
EmitExpression , Stmt.RecordRange End Sub
Private Sub EmitLSet(ByVal Stmt)
Builder.Append "LSet "
EmitExpression , Stmt.Name
Builder.Append " = "
EmitExpression , Stmt.Value End Sub
Private Sub EmitName(ByVal Stmt)
Builder.Append "Name "
EmitExpression , Stmt.OldPathName
Builder.Append " As "
EmitExpression , Stmt.NewPathName End Sub
Private Sub EmitOnError(ByVal Stmt)
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) Dim Count, Target, Label
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.NewEnum If Target.Kind = snLabel Then Set Label = Target
EmitId Label.Id Else
EmitLineNumber Target End If
Count = Count + 1 If Count <> Stmt.Targets.Count Then Builder.Append ", " Next End Sub
Private Sub EmitOpen(ByVal Stmt)
Builder.Append "Open "
EmitExpression , Stmt.PathName
Builder.Append " For "
Select Case Stmt.FileMode Case fmAppend
Builder.Append "Append"
Case fmBinary
Builder.Append "Binary"
Case fmInput
Builder.Append "Input"
Case fmOutput
Builder.Append "Output"
Case fmRandom
Builder.Append "Random" End Select
If Stmt.FileAccess <> faNone Then
Builder.Append " Access "
Select Case Stmt.FileAccess Case faRead
Builder.Append "Read"
Case faReadWrite
Builder.Append "Read Write"
Case faWrite
Builder.Append "Write" End Select End If
Select Case Stmt.FileLock Case flRead
Builder.Append " Read"
Case flReadWrite
Builder.Append " Read Write"
Case flShared
Builder.Append " Shared"
Case flWrite
Builder.Append " Write" End Select
Builder.Append " As "
EmitExpression , Stmt.FileNumber
If Not Stmt.Length Is Nothing Then
Builder.Append " Len="
EmitExpression , Stmt.Length End If End Sub
For Each Arg In Stmt.Output.NewEnum
Count = Count + 1
If Not Arg.Indent Is Nothing Then
Builder.Append IIf(Arg.Indent.IsTab, " Tab", " Spc")
If Not Arg.Indent.Value Is Nothing Then
Builder.Append "("
EmitExpression , Arg.Indent.Value
Builder.Append ")" End If
Builder.Append " " End If
EmitExpression , Arg.Value
If Arg.HasSemicolon Then
Builder.Append ";" Else If Count <> Stmt.Output.Count Then Builder.Append " " End If Next End Sub
Private Sub EmitPut(ByVal Stmt)
Builder.Append "Put "
EmitExpression , Stmt.FileNumber
Builder.Append ", " If Not Stmt.RecNumber Is Nothing Then EmitExpression , Stmt.RecNumber
Builder.Append ", "
EmitToken Stmt.Var.Value End Sub
Private Sub EmitRaiseEvent(ByVal Stmt) Dim Count, Expr
Builder.Append "RaiseEvent "
EmitId Stmt.Id
If Stmt.Arguments.Count > 0 Then
Builder.Append "("
For Each Expr In Stmt.Arguments.NewEnum
EmitExpression , Expr
Count = Count + 1 If Count <> Stmt.Arguments.Count Then Builder.Append ", " Next
Builder.Append ")" End If
Builder.Append " " End Sub
Private Sub EmitReDim(ByVal Stmt) Dim Count, Var
Builder.Append "ReDim " If Stmt.HasPreserve Then Builder.Append "Preserve "
For Each Var In Stmt.Vars.NewEnum
EmitId Var.Id
EmitSubscripts Var.Subscripts
Builder.Append " As "
EmitDataType Var.DataType
Count = Count + 1 If Count <> Stmt.Vars.Count Then Builder.Append ", " Next End Sub
Private Sub EmitReset(ByVal Stmt)
Builder.Append "Reset" End Sub
Private Sub EmitResume(ByVal Stmt)
Builder.Append "Resume"
If Stmt.IsNext Then
Builder.Append " Next "
ElseIf Stmt.Target.Kind = snLabel Then
Builder.Append " " Dim Label: Set Label = Stmt.Target
EmitId Label.Id Else Dim LinNum: 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)
Builder.Append "Return " End Sub
Private Sub EmitRSet(ByVal Stmt)
Builder.Append "RSet "
EmitExpression , Stmt.Name
Builder.Append " = "
EmitExpression , Stmt.Value End Sub
Private Sub EmitSeek(ByVal Stmt)
Builder.Append "Seek "
EmitExpression , Stmt.FileNumber
Builder.Append ", "
EmitExpression , Stmt.Position End Sub
Private Sub EmitSelect(ByVal Stmt) Dim Count, Cond, Cs, Bin
Builder.Append "Select Case "
EmitExpression , Stmt.Value
Builder.AppendLn ""
Builder.Indent
For Each Cs In Stmt.Cases.NewEnum
Count = 0
Builder.Append "Case "
For Each Cond In Cs.Conditions.NewEnum
Count = Count + 1
If Cond.Kind = ekBinaryExpr Then Set Bin = Cond
If Bin.LHS Is Nothing Then
Builder.Append "Is"
EmitOperator Bin.Operator Set Cond = Bin.RHS End If End If
EmitExpression , Cond If Count <> Cs.Conditions.Count Then Builder.Append ", " Next
Builder.AppendLn ""
Builder.Indent
EmitBody Cs.Body
Builder.Deindent Next
If Stmt.CaseElse.Count > 0 Then
Builder.AppendLn "Case Else"
Builder.Indent
EmitBody Stmt.CaseElse
Builder.Deindent End If
Builder.Deindent
Builder.Append "End Select" End Sub
Private Sub EmitSet(ByVal Stmt)
Builder.Append "Set "
EmitExpression , Stmt.Name
Builder.Append " = "
EmitExpression , Stmt.Value End Sub
Private Sub EmitStop(ByVal Stmt)
Builder.Append "Stop " End Sub
Private Sub EmitUnlock(ByVal Stmt)
Builder.Append "Unlock "
EmitExpression , Stmt.FileNumber
Builder.Append ", "
EmitExpression , Stmt.RecordRange End Sub
Private Sub EmitWhile(ByVal Stmt)
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)
Builder.Append "Width "
EmitExpression , Stmt.FileNumber
Builder.Append ", "
EmitExpression , Stmt.Value End Sub
For Each Expr In Stmt.Output.NewEnum
EmitExpression , Expr
Count = Count + 1 If Count <> Stmt.Output.Count Then Builder.Append ", " Next End Sub
Private Sub EmitToken(ByVal Stmt) Select Case Stmt.Kind Case tkBinaryNumber
Builder.Append "&B"
Builder.Append Stmt.Text
Case tkDateTime
Builder.Append "#"
Builder.Append Stmt.Text
Builder.Append "#"
Case tkEscapedIdentifier
Builder.Append "["
Builder.Append Stmt.Text
Builder.Append "]"
Case tkFileHandle, tkFloatNumber, tkIntegerNumber, tkSciNumber
Builder.Append Stmt.Text
Case tkHexaNumber
Builder.Append "&H"
Builder.Append Stmt.Text
Case tkIdentifier, tkKeyword
Builder.Append NameBank_(Stmt)
Case tkOperator
Builder.Append Replace(NameBank_(Stmt), "~", "")
Case tkOctalNumber
Builder.Append "&O"
Builder.Append Stmt.Text
Case tkString
Builder.Append """"
Builder.Append Replace(Stmt.Text, """", """""""")
Builder.Append """"
Case Else
Err.Raise 5 End Select
If Stmt.Suffix <> vbNullChar Then Builder.Append Stmt.Suffix End Sub
Private Sub EmitOperator(ByVal Stmt) If Stmt.IsUnary Then
EmitToken Stmt.Value
Select Case Stmt.Value.Code Case opWithBang, opWithDot, opNeg Rem OK
Case Else
Builder.Append " " End Select
Else Select Case Stmt.Value.Code Case opDot, opBang, opNamed
EmitToken Stmt.Value
Case Else
Builder.Append " "
EmitToken Stmt.Value
Builder.Append " " End Select End If End Sub End Class
Class RSetConstruct Public Name Public Value
Private Sub Class_Initialize() Set Name = Nothing Set Value = Nothing End Sub
Public Property Get Kind()
Kind = snRSet End Property End Class
Class SeekConstruct Public FileNumber Public Position
Private Sub Class_Initialize() Set FileNumber = Nothing Set Position = Nothing End Sub
Public Property Get Kind()
Kind = snSeek End Property End Class
Class SelectConstruct Public Cases Public CaseElse Public Value
Private Sub Class_Initialize() Set Cases = New KeyedList Set CaseElse = New KeyedList Set Value = Nothing End Sub
Public Property Get Kind()
Kind = snSelect End Property End Class
Class SetConstruct Public Name Public Value
Private Sub Class_Initialize() Set Name = Nothing Set Value = Nothing End Sub
Public Property Get Kind()
Kind = snSet End Property End Class
Class SourceFile Public Entities Public Path
Private Sub Class_Initialize() Set Entities = New KeyedList
Entities.CompareMode = vbTextCompare End Sub End Class
Class StopConstruct Public Property Get Kind()
Kind = snStop End Property End Class
Class SubConstruct Public Parameters Public Body Public Access Public IsStatic Public IsDefault Public Id
Private Sub Class_Initialize() Set Parameters = New KeyedList
Parameters.CompareMode = vbTextCompare
Set Body = New KeyedList Set Id = Nothing End Sub End Class
Class SubscriptPair Private UpperBound_
Public LowerBound
Private Sub Class_Initialize() Set UpperBound_ = Nothing Set LowerBound = Nothing End Sub
Public Property Get UpperBound() Set UpperBound = UpperBound_ End Property
Public Property Set UpperBound(ByVal Value) If Not UpperBound_ Is Nothing Then Set LowerBound = UpperBound_ Set UpperBound_ = Value End Property End Class
Class Symbol Public Value
Private Sub Class_Initialize() Set Value = Nothing End Sub
Public Property Get Kind()
Kind = ekSymbol End Property End Class
Class Token Public Code Public Line Public Column Public Spaces Public Text Public Suffix Public Kind
Private Sub Class_Initialize()
Text = " "
Suffix = vbNullChar End Sub
Public Function IsKeyword(ByVal Code) If Kind <> tkKeyword Then Exit Function If Me.Code <> Code Then Exit Function
IsKeyword = True End Function
Public Function IsOperator(ByVal Code) If Kind <> tkOperator Then Exit Function If Me.Code <> Code Then Exit Function
IsOperator = True End Function End Class
Class TupleConstruct Public Elements
Private Sub Class_Initialize() Set Elements = New KeyedList End Sub
Public Property Get Kind()
Kind = ekTuple End Property End Class
Class TypeConstruct Public Members Public Access Public Id
Private Sub Class_Initialize() Set Members = New KeyedList
Members.CompareMode = vbTextCompare Set Id = Nothing End Sub End Class
Class UnaryExpression Public Operator Public Value
Private Sub Class_Initialize() Set Operator = Nothing Set Value = Nothing End Sub
Public Property Get Kind()
Kind = ekUnaryExpr End Property End Class
Class UnlockConstruct Public FileNumber Public RecordRange
Private Sub Class_Initialize() Set FileNumber = Nothing Set RecordRange = Nothing End Sub
Public Property Get Kind()
Kind = snUnlock End Property End Class
Class Variable Private Id_
Public Subscripts Public IsStatic Public HasWithEvents Public HasNew Public DataType Public Init Public Access
Private Sub Class_Initialize() Set Subscripts = New KeyedList Set Id_ = New Identifier Set DataType = Nothing Set Init = Nothing End Sub
Public Property Get Id() Set Id = Id_ End Property
Public Property Get Kind()
Kind = snDim End Property End Class
Class WhileConstruct Public Body Public Condition
Private Sub Class_Initialize() Set Body = New KeyedList Set Condition = Nothing End Sub
Public Property Get Kind()
Kind = snWhile End Property End Class
Class WidthConstruct Public FileNumber Public Value
Private Sub Class_Initialize() Set FileNumber = Nothing Set Value = Nothing End Sub
Public Property Get Kind()
Kind = snWidth End Property End Class
Class WithConstruct Public Body Public PinObject
Private Sub Class_Initialize() Set Body = New KeyedList Set PinObject = Nothing End Sub
Public Property Get Kind()
Kind = snWith End Property End Class
Class WriteConstruct Public Output Public FileNumber
Private Sub Class_Initialize() Set Output = New KeyedList Set FileNumber = Nothing End Sub
Public Property Get Kind()
Kind = snWrite End Property End Class
Case opCompSum, opCompSubt, opCompMul, opCompDiv, opCompIntDiv, opCompPow, opCompConcat, opCompLSh, _
opCompRSh, opCompURSh, opCompAnd, opCompEqv, opCompImp, opCompMod, opCompOr, opCompXor
Precedence = 1 End Select End Function
'Messages Const Msg001 = "Public, Private, Class, or Module" Const Msg002 = "Class or Module" Const Msg003 = "identifier" Const Msg004 = "Rule: End (Class | Module)" Const Msg005 = "Rule: vbCr | vbLf | vbCrLf | : | '" Const Msg006 = "Ambiguous name detected: " Const Msg007 = "Rule: [Public | Private] (Class | Module) identifier" Const Msg008 = "Rule: [Public | Private] identifier" Const Msg010 = "Duplicated Option statement" Const Msg011 = "Rule: Option Base (0 | 1)" Const Msg012 = "Rule: [Public] Event identifier [([parms])]" Const Msg013 = "Rule: Option Compare (Binary | Text)" Const Msg014 = "Binary or Text" Const Msg015 = "Rule: Option (Base | Compare | Explicit)" Const Msg016 = "Only valid inside Class" Const Msg017 = "Event can only be Public" Const Msg018 = "Expected: Option or Deftype or Public or Private or Const or Enum or Declare or Type" Const Msg019 = "Rule: DefType first[-last] [, ...]" Const Msg020 = "first" Const Msg021 = "last" Const Msg022 = "Duplicated Deftype statement" Const Msg023 = "Rule: [Public | Private] Const identifier [As datatype] = expression [, ...]" Const Msg024 = "Identifier already has a type-declaration character" Const Msg025 = "datatype" Const Msg026 = "Fixed-length allowed only for String" Const Msg027 = "list separator or end of statement" Const Msg028 = "Rule: [Public | Private] Enum identifier" Const Msg029 = "Enum cannot have a type-declaration character" Const Msg030 = "Expected: Append or Binary or Input or Random" Const Msg031 = "End of statement" Const Msg032 = "Rule: identifier [= expression]" Const Msg033 = "Enum member cannot have a type-declaration character" Const Msg034 = "Rule: End Enum" Const Msg035 = "Enum without members is not allowed" Const Msg036 = "Rule: [Public | Private] Declare (Sub | Function) identifier [CDecl] Lib lib_string [Alias alias_string] ([parms]) [As data_type[()]]" Const Msg037 = "Sub or Function" Const Msg038 = "lib string" Const Msg039 = "alias string" Const Msg040 = "Duplicated declaration in current scope" Const Msg041 = "Rule: [[Optional] (ByVal | ByRef) | ParamArray] identifier[type_declaration_char][()] [As data_type] [:= expression]" Const Msg042 = "Too many formal parameters" Const Msg043 = "Cannot have both Optional and ParamArray parameters" Const Msg044 = "Optional not allowed" Const Msg045 = "ParamArray not allowed" Const Msg046 = "ByVal not allowed" Const Msg047 = "ByRef not allowed" Const Msg048 = "ParamArray parameter must be an array" Const Msg049 = "Identifier already has a type-declaration character" Const Msg050 = "As [project_name.]identifier" Const Msg051 = "ParamArray must be an array of Variants" Const Msg052 = "Sub, Property Let, or Property Get cannot have an As clause" Const Msg053 = "Parameter is not Optional" Const Msg054 = "ParamArray cannot have a default value" Const Msg057 = "Unclosed parenthesis" Const Msg058 = "Rule: Implements [project_name.]identifier" Const Msg059 = "Project name or identifier" Const Msg060 = "Type-declaration character not allowed here" Const Msg061 = "(Public | Private | Static | Dim) [WithEvents] identifier[type_declaration_character][([[n To] m[, ...]])] [As (data_type [= expression] | New class_name)] [, ...]" Const Msg062 = "Invalid use of New" Const Msg063 = "Invalid inside Sub, Function, or Property" Const Msg064 = "Invalid use of New with array" Const Msg065 = "Invalid expression" Const Msg067 = "Rule: member_name As data_type" Const Msg068 = "Rule: End Type" Const Msg069 = "Rule: [Public | Private | Friend] [Static] [Default] Sub identifier[([parms])]" Const Msg070 = "Rule: [Public | Private | Friend] [Static] [Default] Function identifier[type_declaration_character][()][([parms])] [As datatype[()]]" Const Msg071 = "Rule: [Public | Private | Friend] [Static] [Default] Property (Get | Let | Set) identifier[type_declaration_character][()][([parms])] [As datatype[()]]" Const Msg072 = "Rule: End Sub" Const Msg073 = "Rule: End Function" Const Msg074 = "Rule: End Property" Const Msg075 = "Expected: Read or Write" Const Msg076 = "Get or Let or Set" Const Msg077 = "Definitions of property procedures for the same property are inconsistent, or property procedure has an optional parameter, a ParamArray, or an invalid Set final parameter" Const Msg078 = "Argument required for Property Let or Property Set" Const Msg079 = "Rule: (Public | Private | Friend) identifier" Const Msg080 = "Duplicated Static statement" Const Msg081 = "Duplicated Iterator statement" Const Msg082 = "Duplicated Default statement" Const Msg083 = "A Function cannot be both Default and Iterator" Const Msg084 = "Expected: = or argument" Const Msg085 = "Expected: End " Const Msg086 = "Expected: Get or Let or Set" Const Msg087 = "Expected: statement" Const Msg088 = "Rule: If condition Then" Const Msg089 = "Expected: Else or ElseIf or End If" Const Msg090 = "Block If without End If" Const Msg091 = "Rule: Select Case expression" Const Msg092 = "Expected: > or >= or = or < or <= or <>" Const Msg093 = "Expected: Is or Else" Const Msg094 = "Expected: = or argument" Const Msg095 = "Expected: Do or For or While" Const Msg096 = "Expected: Loop" Const Msg097 = "Rule: Erase identifier" Const Msg098 = "Expected: Do or For or Function or Property or Sub or Select or While" Const Msg099 = "Rule: For identifier = start To end [Step increment]" Const Msg100 = "increment" Const Msg101 = "Expected: Next" Const Msg102 = "Rule: For Each variable In group" Const Msg103 = "variable" Const Msg104 = "group" Const Msg105 = "Rule: Get [#]filenumber, [recnumber], varname" Const Msg107 = "Rule: Put [#]filenumber, [recnumber], varname" Const Msg108 = "Expected: Label or line number" Const Msg109 = "Rule: Input #filenumber, variable[, variable, ...]" Const Msg110 = "#filenumber" Const Msg112 = "Lock [#]filenumber[, recordrange]" Const Msg113 = "recordrange" Const Msg114 = "Rule: LSet variable = value" Const Msg115 = "Rule: Name oldpathname As newpathname" Const Msg116 = "oldpathname" Const Msg117 = "newpathname" Const Msg118 = "Expected: GoTo or Resume" Const Msg119 = "Rule: Open pathname For mode [Access access] [lock] As [#]filenumber [Len=reclength]" Const Msg120 = "pathname" Const Msg121 = "Print #filenumber, [outputlist]" Const Msg122 = "Expected: subscript" Const Msg123 = "Rule: Seek [#]filenumber, position" Const Msg124 = "position" Const Msg125 = "Rule: Unlock [#]filenumber[, recordrange]" Const Msg126 = "Rule: While condition" Const Msg127 = "Expected: Wend or End While" Const Msg128 = "Rule: Width #filenumber, width" Const Msg129 = "width" Const Msg130 = "Rule: With object" Const Msg131 = "object" Const Msg132 = "Expected: End With" Const Msg133 = "Rule: Write #filenumber, [outputlist]"
'Vocabulary Class Vocabulary Rem Contextual in VB6 Public Property Get Access()
Access = "Access" End Property
Public Property Get [AddressOf]()
[AddressOf] = "AddressOf" End Property
Rem Contextual in VB6 Public Property Get Alias()
Alias = "Alias" End Property
Public Property Get [And]()
[And] = "And" End Property
Rem New! Public Property Get AndAlso()
AndAlso = "AndAlso" End Property
Public Property Get [Any]()
[Any] = "Any" End Property
Rem Contextual in VB6 Public Property Get Append()
Append = "Append" End Property
Public Property Get [As]()
[As] = "As" End Property
Public Property Get [Attribute]()
[Attribute] = "Attribute" End Property
Rem Contextual in VB6 Public Property Get Base()
Base = "Base" End Property
Rem Contextual in VB6 Public Property Get Binary()
Binary = "Binary" End Property
Public Property Get [Boolean]()
[Boolean] = "Boolean" End Property
Public Property Get [ByRef]()
[ByRef] = "ByRef" End Property
Public Property Get [ByVal]()
[ByVal] = "ByVal" End Property
Public Property Get [Byte]()
[Byte] = "Byte" End Property
Public Property Get [Call]()
[Call] = "Call" End Property
Public Property Get [Case]()
[Case] = "Case" End Property
Public Property Get CDecl()
CDecl = "CDecl" End Property
Public Property Get [Circle]()
[Circle] = "Circle" End Property
Rem New! Public Property Get [Class]()
[Class] = "Class" End Property
Public Property Get [Close]()
[Close] = "Close" End Property
Rem Contextual in VB6 Public Property Get Compare()
Compare = "Compare" End Property
Public Property Get [Const]()
[Const] = "Const" End Property
Rem New! Public Property Get Continue()
Continue = "Continue" End Property
Public Property Get [Currency]()
[Currency] = "Currency" End Property
Public Property Get [Date]()
[Date] = "Date" End Property
Public Property Get [Decimal]()
[Decimal] = "Decimal" End Property
Public Property Get [Debug]()
[Debug] = "Debug" End Property
Public Property Get [Declare]()
[Declare] = "Declare" End Property
Rem New! Public Property Get [Default]()
[Default] = "Default" End Property
Public Property Get [DefBool]()
[DefBool] = "DefBool" End Property
Public Property Get [DefByte]()
[DefByte] = "DefByte" End Property
Public Property Get [DefCur]()
[DefCur] = "DefCur" End Property
Public Property Get [DefDate]()
[DefDate] = "DefDate" End Property
Public Property Get [DefDbl]()
[DefDbl] = "DefDbl" End Property
Public Property Get [DefDec]()
[DefDec] = "DefDec" End Property
Public Property Get [DefInt]()
[DefInt] = "DefInt" End Property
Public Property Get [DefLng]()
[DefLng] = "DefLng" End Property
Rem New! Public Property Get DefLngLng()
DefLngLng = "DefLngLng" End Property
Rem New! Public Property Get DefLngPtr()
DefLngPtr = "DefLngPtr" End Property
Public Property Get [DefObj]()
[DefObj] = "DefObj" End Property
Public Property Get [DefSng]()
[DefSng] = "DefSng" End Property
Public Property Get [DefStr]()
[DefStr] = "DefStr" End Property
Public Property Get [DefVar]()
[DefVar] = "DefVar" End Property
Public Property Get [Dim]()
[Dim] = "Dim" End Property
Public Property Get [Do]()
[Do] = "Do" End Property
Public Property Get [Double]()
[Double] = "Double" End Property
Public Property Get [Each]()
[Each] = "Each" End Property
Public Property Get [ElseIf]()
[ElseIf] = "ElseIf" End Property
Public Property Get [Else]()
[Else] = "Else" End Property
Public Property Get [Empty]()
[Empty] = "Empty" End Property
Public Property Get [End]()
[End] = "End" End Property
Public Property Get [EndIf]()
[EndIf] = "EndIf" End Property
Public Property Get [Enum]()
[Enum] = "Enum" End Property
Public Property Get [Eqv]()
[Eqv] = "Eqv" End Property
Public Property Get [Erase]()
[Erase] = "Erase" End Property
Rem Contextual in VB6 Public Property Get Error()
Error = "Error" End Property
Public Property Get [Event]()
[Event] = "Event" End Property
Public Property Get [Exit]()
[Exit] = "Exit" End Property
Rem Contextual in VB6 Public Property Get Explicit()
Explicit = "Explicit" End Property
Public Property Get [False]()
[False] = "False" End Property
Public Property Get [For]()
[For] = "For" End Property
Public Property Get [Friend]()
[Friend] = "Friend" End Property
Public Property Get [Function]()
[Function] = "Function" End Property
Public Property Get [Get]()
[Get] = "Get" End Property
Public Property Get [Global]()
[Global] = "Global" End Property
Public Property Get [GoSub]()
[GoSub] = "GoSub" End Property
Public Property Get [GoTo]()
[GoTo] = "GoTo" End Property
Public Property Get [If]()
[If] = "If" End Property
Public Property Get [Imp]()
[Imp] = "Imp" End Property
Public Property Get [Implements]()
[Implements] = "Implements" End Property
Public Property Get [In]()
[In] = "In" End Property
Public Property Get [Input]()
[Input] = "Input" End Property
Public Property Get [Integer]()
[Integer] = "Integer" End Property
Public Property Get [Is]()
[Is] = "Is" End Property
Rem New! Public Property Get IsNot()
IsNot = "IsNot" End Property
Rem New! Public Property Get Iterator()
Iterator = "Iterator" End Property
Public Property Get [Let]()
[Let] = "Let" End Property
Rem Contextual in VB6 Public Property Get Lib()
Lib = "Lib" End Property
Public Property Get [Like]()
[Like] = "Like" End Property
Rem Contextual in VB6 Public Property Get Line()
Line = "Line" End Property
Public Property Get [Lock]()
[Lock] = "Lock" End Property
Public Property Get [Local]()
[Local] = "Local" End Property
Public Property Get [Long]()
[Long] = "Long" End Property
Rem New! Public Property Get LongPtr()
LongPtr = "LongPtr" End Property
Rem New! Public Property Get LongLong()
LongLong = "LongLong" End Property
Public Property Get [Loop]()
[Loop] = "Loop" End Property
Public Property Get [LSet]()
[LSet] = "LSet" End Property
Public Property Get [Len]()
[Len] = "Len" End Property
Public Property Get [Me]()
[Me] = "Me" End Property
Public Property Get [Mod]()
[Mod] = "Mod" End Property
Rem Upgraded from contextual keyword (Option Private Module) to keyword Public Property Get Module()
Module = "Module" End Property
Rem Contextual in VB6 Public Property Get Name()
Name = "Name" End Property
Public Property Get [New]()
[New] = "New" End Property
Public Property Get [Next]()
[Next] = "Next" End Property
Public Property Get [Not]()
[Not] = "Not" End Property
Public Property Get [Nothing]()
[Nothing] = "Nothing" End Property
Public Property Get [Null]()
[Null] = "Null" End Property
Rem Contextual in VB6 Public Property Get Object()
Object = "Object" End Property
Public Property Get [On]()
[On] = "On" End Property
Public Property Get [Open]()
[Open] = "Open" End Property
Public Property Get [Option]()
[Option] = "Option" End Property
Public Property Get [Optional]()
[Optional] = "Optional" End Property
Public Property Get [Or]()
[Or] = "Or" End Property
Rem New! Public Property Get OrElse()
OrElse = "OrElse" End Property
Rem Contextual in VB6 Public Property Get Output()
Output = "Output" End Property
Public Property Get [ParamArray]()
[ParamArray] = "ParamArray" End Property
Public Property Get [PSet]()
[PSet] = "PSet" End Property
Public Property Get [Preserve]()
[Preserve] = "Preserve" End Property
Public Property Get [Print]()
[Print] = "Print" End Property
Public Property Get [Private]()
[Private] = "Private" End Property
Public Property Get Property()
Property = "Property" End Property
Rem New! Public Property Get PtrSafe()
PtrSafe = "PtrSafe" End Property
Public Property Get [Public]()
[Public] = "Public" End Property
Public Property Get [Put]()
[Put] = "Put" End Property
Public Property Get [RaiseEvent]()
[RaiseEvent] = "RaiseEvent" End Property
Rem Contextual in VB6 Public Property Get Random()
Random = "Random" End Property
Rem Contextual in VB6 Public Property Get Read()
Read = "Read" End Property
Public Property Get [ReDim]()
[ReDim] = "ReDim" End Property
Public Property Get [Rem]()
[Rem] = "Rem" End Property
Rem Contextual in VB6 Public Property Get Reset()
Reset = "Reset" End Property
Public Property Get [Resume]()
[Resume] = "Resume" End Property
Public Property Get [Return]()
[Return] = "Return" End Property
Public Property Get [RSet]()
[RSet] = "RSet" End Property
Public Property Get [Seek]()
[Seek] = "Seek" End Property
Public Property Get [Select]()
[Select] = "Select" End Property
Public Property Get [Set]()
[Set] = "Set" End Property
Public Property Get [Scale]()
[Scale] = "Scale" End Property
Public Property Get [Shared]()
[Shared] = "Shared" End Property
Public Property Get [Single]()
[Single] = "Single" End Property
Public Property Get [Static]()
[Static] = "Static" End Property
Rem Keyword in VB6, demoted to contextual Public Property Get [Spc]()
[Spc] = "Spc" End Property
Rem Contextual in VB6 Public Property Get Step()
Step = "Step" End Property
Rem Keyword in VB6, demoted to contextual Public Property Get [Tab]()
[Tab] = "Tab" End Property
Public Property Get [Stop]()
[Stop] = "Stop" End Property
Public Property Get [String]()
[String] = "String" End Property
Public Property Get [Sub]()
[Sub] = "Sub" End Property
Rem Contextual in VB6 Public Property Get Text()
Text = "Text" End Property
Public Property Get [Then]()
[Then] = "Then" End Property
Public Property Get [To]()
[To] = "To" End Property
Public Property Get [True]()
[True] = "True" End Property
Public Property Get [Type]()
[Type] = "Type" End Property
Public Property Get [TypeOf]()
[TypeOf] = "TypeOf" End Property
Public Property Get [Unlock]()
[Unlock] = "Unlock" End Property
Public Property Get [Until]()
[Until] = "Until" End Property
Public Property Get [Variant]()
[Variant] = "Variant" End Property
Public Property Get Void()
Void = "" End Property
Public Property Get [Wend]()
[Wend] = "Wend" End Property
Public Property Get [While]()
[While] = "While" End Property
Rem Contextual in VB6 Public Property Get Width()
Width = "Width" End Property
Public Property Get [With]()
[With] = "With" End Property
Public Property Get [WithEvents]()
[WithEvents] = "WithEvents" End Property
Public Property Get [Write]()
[Write] = "Write" End Property
Public Property Get [Xor]()
[Xor] = "Xor" End Property End Class
'VBScript specifics Function Named(Name, Value) If IsObject(Value) Then Set Named = Value Else Named = Value End Function
Function IIf(Expression, TruePart, FalsePart) If Expression Then If IsObject(TruePart) Then Set IIf = TruePart Else IIf = TruePart Else If IsObject(FalsePart) Then Set IIf = FalsePart Else IIf = FalsePart End If End Function
Function IsMissing(Value)
IsMissing = VarType(Value) = vbError End Function
Function Switch(Test1, Value1, Test2, Value2, Test3, Value3)
Switch = Value1 If Test1 Then Exit Function
Switch = Value2 If Test2 Then Exit Function
Switch = Value3 If Test3 Then Exit Function
Switch = Null End Function
'StringCentral Const NO_OF_COLS = 5
Rem The first (high) surrogate is a 16-bit code value in the range U+D800 to U+DBFF. Private Function IsHighSurrogate(ByVal Character)
IsHighSurrogate = Character >= -10240 And Character <= -9217 Or Character >= 55296 And Character <= 56319 End Function
Rem The second (low) surrogate is a 16-bit code value in the range U+DC00 to U+DFFF. Private Function IsLowSurrogate(ByVal Character)
IsLowSurrogate = Character >= -9216 And Character <= -8193 Or Character >= 56320 And Character <= 57343 End Function
Public Function IsSurrogate(ByVal Character)
IsSurrogate = IsLowSurrogate(Character) Or IsHighSurrogate(Character) End Function
Public Function IsLetter(ByVal CodePoint) If CodePoint >= -32768 And CodePoint <= -24645 Or _
CodePoint >= -24576 And CodePoint <= -23412 Or _
CodePoint >= -22761 And CodePoint <= -22758 Or _
CodePoint >= -22528 And CodePoint <= -22527 Or _
CodePoint >= -22525 And CodePoint <= -22523 Or _
CodePoint >= -22521 And CodePoint <= -22518 Or _
CodePoint >= -22516 And CodePoint <= -22494 Or _
CodePoint >= -22464 And CodePoint <= -22413 Or _
CodePoint >= -21504 And CodePoint <= -10333 Or _
CodePoint >= -1792 And CodePoint <= -1491 Or _
CodePoint >= -1488 And CodePoint <= -1430 Or _
CodePoint >= -1424 And CodePoint <= -1319 Or _
CodePoint >= -1280 And CodePoint <= -1274 Or _
CodePoint >= -1261 And CodePoint <= -1257 Or _
CodePoint = -1251 Or _
CodePoint >= -1249 And CodePoint <= -1240 Or _
CodePoint >= -1238 And CodePoint <= -1226 Or _
CodePoint >= -1224 And CodePoint <= -1220 Or _
CodePoint = -1218 Or _
CodePoint = -1216 Or _
CodePoint = -1215 Or _
CodePoint = -1213 Or _
CodePoint = -1212 Or _
CodePoint >= -1210 And CodePoint <= -1103 Or _
CodePoint = -1069 Or _
CodePoint >= -1068 And CodePoint <= -707 Or _
CodePoint >= -688 And CodePoint <= -625 Or _
CodePoint >= -622 And CodePoint <= -569 Or _
CodePoint >= -528 And CodePoint <= -517 Or _
CodePoint >= -400 And CodePoint <= -396 Or _
CodePoint >= -394 And CodePoint <= -260 Or _
CodePoint >= -223 And CodePoint <= -198 Or _
CodePoint >= -191 And CodePoint <= -166 Or _
CodePoint >= -154 And CodePoint <= -66 Or _
CodePoint >= -62 And CodePoint <= -57 Or _
CodePoint >= -54 And CodePoint <= -49 Or _
CodePoint >= -46 And CodePoint <= -41 Or _
CodePoint >= -38 And CodePoint <= -36 Or _
CodePoint >= 65 And CodePoint <= 90 Or _
CodePoint >= 97 And CodePoint <= 122 Or _
CodePoint = 170 Or _
CodePoint = 181 Or _
CodePoint = 186 Or _
CodePoint >= 192 And CodePoint <= 214 Or _
CodePoint >= 216 And CodePoint <= 246 Or _
CodePoint >= 248 And CodePoint <= 705 Or _
CodePoint >= 710 And CodePoint <= 721 Or _
CodePoint >= 736 And CodePoint <= 740 Or _
CodePoint = 750 Or _
CodePoint >= 890 And CodePoint <= 893 Or _
CodePoint = 902 Or _
CodePoint >= 904 And CodePoint <= 906 Or _
CodePoint = 908 Or _
CodePoint >= 910 And CodePoint <= 929 Or _
CodePoint >= 931 And CodePoint <= 974 Or _
CodePoint >= 976 And CodePoint <= 1013 Or _
CodePoint >= 1015 And CodePoint <= 1153 Or _
CodePoint >= 1162 And CodePoint <= 1299 Or _
CodePoint >= 1329 And CodePoint <= 1366 Or _
CodePoint = 1369 Or _
CodePoint >= 1377 And CodePoint <= 1415 Or _
CodePoint >= 1488 And CodePoint <= 1514 Or _
CodePoint >= 1520 And CodePoint <= 1522 Or _
CodePoint >= 1569 And CodePoint <= 1594 Or _
CodePoint >= 1600 And CodePoint <= 1610 Or _
CodePoint = 1646 Or _
CodePoint = 1647 Or _
CodePoint >= 1649 And CodePoint <= 1747 Or _
CodePoint = 1749 Or _
CodePoint = 1765 Or _
CodePoint = 1766 Or _
CodePoint = 1774 Or _
CodePoint = 1775 Or _
CodePoint >= 1786 And CodePoint <= 1788 Or _
CodePoint = 1791 Or _
CodePoint = 1808 Or _
CodePoint >= 1810 And CodePoint <= 1839 Or _
CodePoint >= 1869 And CodePoint <= 1901 Or _
CodePoint >= 1920 And CodePoint <= 1957 Or _
CodePoint = 1969 Or _
CodePoint >= 1994 And CodePoint <= 2026 Or _
CodePoint = 2036 Or _
CodePoint = 2037 Or _
CodePoint = 2042 Then
IsLetter = True End If End Function
Public Sub Main() Dim Source: Set Source = New SourceFile
Source.Path = WScript.Arguments(0)
Dim Parser: Set Parser = New Parser
Parser.Parse Source
Dim Builder: Set Builder = New FileTextBuilder
Builder.FilePath = Source.Path & ".out"
Dim Revert: Set Revert = New Reverter Set Revert.Builder = Builder
Revert.Transpile Source End Sub
Public Sub PrettyPrint() Dim HtmlFile, Text, Token
Rem File path for the source code is passed as a command-line argument. Dim Source: Set Source = New SourceFile Dim FilePath: FilePath = WScript.Arguments(0)
Source.Path = FilePath
Dim Parser: 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: Index = InStrRev(FilePath, ".") If Index <> 0 Then FilePath = Left(FilePath, Index - 1)
FilePath = FilePath & ".html"
With CreateObject("Scripting.FileSystemObject") Set HtmlFile = .OpenTextFile(FilePath, ForWriting, Named("Create:=", True), Named("Format:=Unicode", True)) End With
Dim Nbsp: Nbsp = True
Do Set Token = Parser.NextTokenForPrint
If Nbsp Then For Index = 1 To Token.Spaces
HtmlFile.Access " " Next Else
HtmlFile.Access Space(Token.Spaces) End If
Select Case Token.Kind Case tkComment
HtmlFile.Access SPAN_COMMENT & EncodeHtml(Token.Text) & "</span><br>"
Nbsp = True
Case tkIdentifier
HtmlFile.Access NameBank_(Token)
Nbsp = False
Case tkIntegerNumber, tkFloatNumber, tkSciNumber
HtmlFile.Access Token.Text
Nbsp = False
Case tkOctalNumber
HtmlFile.Access "&O" & Token.Text
Case tkHexaNumber
HtmlFile.Access "&H" & UCase(Token.Text)
Case tkFileHandle
HtmlFile.Access "#" & Token.Text
Case tkString
Text = Token.Text
Text = Replace(Token.Text, """", """""")
Text = EncodeHtml(Text)
HtmlFile.Access SPAN_STRING & """" & Text & """</span>"
Case tkDateTime
HtmlFile.Access "#" & Token.Text & "#"
Case tkOperator If IsLetter(AscW(NameBank_(Token))) Then
HtmlFile.Access SPAN_KEYWORD & NameBank_(Token) & "</span>"
Else
HtmlFile.Access EncodeHtml(NameBank_(Token)) End If
Case tkLeftParenthesis
HtmlFile.Access "("
Nbsp = False
Case tkRightParenthesis
HtmlFile.Access ")"
Nbsp = False
Case tkListSeparator
HtmlFile.Access ","
Nbsp = False
Case tkSoftLineBreak
HtmlFile.Access ":"
Nbsp = False
Case tkPrintSeparator
HtmlFile.Access ";"
Nbsp = False
Case tkLineContinuation
HtmlFile.WriteLine " _<br>"
Nbsp = True
Case tkHardLineBreak
HtmlFile.WriteLine "<br />"
Nbsp = True
Case tkDirective
HtmlFile.Access "#" & Token.Text
Nbsp = False
Case tkEndOfStream Exit Do End Select
If Token.Suffix <> vbNullChar Then HtmlFile.Access Token.Suffix Loop End Sub
Private Function EncodeHtml(ByVal Text)
Text = Replace(Text, "&", "&")
Text = Replace(Text, "<", "<")
Text = Replace(Text, ">", ">")
EncodeHtml = Text End Function