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