1818 lines
70 KiB
VB.net
1818 lines
70 KiB
VB.net
Attribute VB_Name = "stdLambda"
|
|
|
|
'Ensure Option-Explicit is disabled!!
|
|
'For VB6 compatibility we rely on the auto-definition of Application and ThisWorkbook
|
|
'Option Explicit
|
|
|
|
'Used for enabling some debugging features
|
|
#Const devMode = True
|
|
|
|
'For Mac testing purposes only
|
|
'#const Mac = true
|
|
|
|
|
|
|
|
'Implement stdICallable interface
|
|
Implements stdICallable
|
|
|
|
'Direct call convention of VBA.CallByName
|
|
#If Not Mac Then
|
|
#If VBA7 Then
|
|
'VBE7 is interchangable with msvbvm60.dll however VBE7.dll appears to always be present where as msvbvm60 is only occasionally present.
|
|
Private Declare PtrSafe Function rtcCallByName Lib "VBE7.dll" (ByVal cObj As Object, ByVal sMethod As LongPtr, ByVal eCallType As VbCallType, ByRef pArgs() As Variant, ByVal lcid As Long) As Variant
|
|
#Else
|
|
Private Declare Function rtcCallByName Lib "msvbvm60" (ByVal cObj As Object, ByVal sMethod As Long, ByVal eCallType As VbCallType, ByRef pArgs() As Variant, ByVal lcid As Long) As Variant
|
|
#End If
|
|
#End If
|
|
|
|
|
|
'Tokens, token definitions and operations
|
|
Private Type TokenDefinition
|
|
name As String
|
|
Regex As String
|
|
RegexObj As Object
|
|
End Type
|
|
Private Type token
|
|
Type As TokenDefinition
|
|
value As Variant
|
|
BracketDepth As Long
|
|
End Type
|
|
Private Type Operation
|
|
Type As iType
|
|
subType As ISubType
|
|
value As Variant
|
|
End Type
|
|
|
|
'Evaluation operation types
|
|
Private Enum iType
|
|
oPush = 1
|
|
oPop = 2
|
|
oMerge = 3
|
|
oAccess = 4
|
|
oSet = 5
|
|
oArithmetic = 6
|
|
oLogic = 7
|
|
oFunc = 8
|
|
oComparison = 9
|
|
oMisc = 10
|
|
oJump = 11
|
|
oReturn = 12
|
|
oObject = 13
|
|
End Enum
|
|
Private Enum ISubType
|
|
'Arithmetic
|
|
oAdd = 1
|
|
oSub = 2
|
|
oMul = 3
|
|
oDiv = 4
|
|
oPow = 5
|
|
oNeg = 6
|
|
oMod = 7
|
|
'Logic
|
|
oAnd = 8
|
|
oOr = 9
|
|
oNot = 10
|
|
oXor = 11
|
|
'comparison
|
|
oEql = 12
|
|
oNeq = 13
|
|
oLt = 14
|
|
oLte = 15
|
|
oGt = 16
|
|
oGte = 17
|
|
oIs = 18
|
|
'misc operators
|
|
oCat = 19
|
|
oLike = 20
|
|
'misc
|
|
ifTrue = 21
|
|
ifFalse = 22
|
|
withValue = 23
|
|
argument = 24
|
|
'object
|
|
oPropGet = 25
|
|
oPropLet = 26
|
|
oPropSet = 27
|
|
oMethodCall = 28
|
|
oFieldCall = 29
|
|
oEquality = 30 'Yet to be implemented
|
|
oIsOperator = 31 'Yet to be implemented
|
|
oEnum = 32 'Yet to be implemented
|
|
End Enum
|
|
|
|
'Special constant used in parsing:
|
|
Const UniqueConst As String = "3207af79-30df-4890-ade1-640f9f28f309"
|
|
|
|
Private tokens() As token
|
|
Private iTokenIndex As Long
|
|
Private operations() As Operation
|
|
Private iOperationIndex As Long
|
|
Private stackSize As Long
|
|
Private scopes() As Variant
|
|
Private scopesArgCount() As Variant
|
|
Private scopeCount As Long
|
|
Private funcScope As Long
|
|
Private pEquation As String
|
|
|
|
Private Enum LambdaType
|
|
iStandardLambda = 1
|
|
iBoundLambda = 2
|
|
End Enum
|
|
|
|
|
|
Const minStackSize = 30 'note that the stack size may become smaller than this
|
|
|
|
'@protected
|
|
Public oFunctExt As Object 'Dictionary<string => stdCallback>
|
|
|
|
Private oCache As Object
|
|
Private bBound As Boolean
|
|
Private oBound As stdLambda
|
|
Private vBound As Variant
|
|
Private bUsePerformanceCache As Boolean
|
|
Private pPerformanceCache As Object
|
|
|
|
''Usage:
|
|
'Debug.Print stdLambda.Create("1+3*8/2*(2+2+3)").Execute()
|
|
'With stdLambda.Create("$1+1+3*8/2*(2+2+3)")
|
|
' Debug.Print .Execute(10)
|
|
' Debug.Print .Execute(15)
|
|
' Debug.Print .Execute(20)
|
|
'End With
|
|
'Debug.Print stdLambda.Create("$1.Range(""A1"")").Execute(Sheets(1)).Address(True, True, xlA1, True)
|
|
'Debug.Print stdLambda.Create("$1.join("","")").Execute(stdArray.Create(1,2))
|
|
Public Function Create(ByVal sEquation As String, Optional ByVal bUsePerformanceCache As Boolean = False, Optional ByVal bSandboxExtras As Boolean = False) As stdLambda
|
|
'Cache Lambda created
|
|
If oCache Is Nothing Then Set oCache = CreateObject("Scripting.Dictionary")
|
|
Dim sID As String: sID = bUsePerformanceCache & "-" & bSandboxExtras & ")" & sEquation
|
|
If Not oCache.Exists(sID) Then
|
|
Set oCache(sID) = New stdLambda
|
|
Call oCache(sID).Init(LambdaType.iStandardLambda, sEquation, bUsePerformanceCache, bSandboxExtras)
|
|
End If
|
|
|
|
'Return cached lambda
|
|
Set Create = oCache(sID)
|
|
End Function
|
|
|
|
Public Function CreateMultiline(ByRef sEquation As Variant, Optional ByVal bUsePerformanceCache As Boolean = False, Optional ByVal bSandboxExtras As Boolean = False) As stdLambda
|
|
Set CreateMultiline = Create(Join(sEquation, " "), bUsePerformanceCache, bSandboxExtras)
|
|
End Function
|
|
|
|
Public Function BindEx(ByVal params As Variant) As stdLambda
|
|
Set BindEx = New stdLambda
|
|
Dim callable As stdICallable: Set callable = Me
|
|
Call BindEx.Init(LambdaType.iBoundLambda, callable, params)
|
|
End Function
|
|
|
|
'Bind a global variable to the function
|
|
'@param {String} - New global name
|
|
'@param {Variant}- Data to store in global variable
|
|
'@returns {stdLambda} The lambda existing lambda
|
|
Public Function BindGlobal(ByVal sGlobalName As String, ByVal variable As Variant) As stdLambda
|
|
Set BindGlobal = Me
|
|
If bBound Then
|
|
Call oBound.BindGlobal(sGlobalName, variable)
|
|
Else
|
|
If oFunctExt Is Nothing Then Set oFunctExt = CreateObject("Scripting.Dictionary")
|
|
If isObject(variable) Then
|
|
Set oFunctExt(sGlobalName) = variable
|
|
Else
|
|
Let oFunctExt(sGlobalName) = variable
|
|
End If
|
|
End If
|
|
End Function
|
|
|
|
|
|
Public Sub Init(ByVal iLambdaType As Long, ParamArray params() As Variant)
|
|
Select Case iLambdaType
|
|
Case LambdaType.iStandardLambda
|
|
Dim sEquation As String: sEquation = params(0)
|
|
pEquation = sEquation
|
|
bUsePerformanceCache = params(1)
|
|
Dim bSandboxExtras As Boolean: bSandboxExtras = params(2)
|
|
|
|
'Performance cache
|
|
If bUsePerformanceCache Then Set pPerformanceCache = CreateObject("Scripting.Dictionary")
|
|
|
|
'Function extensions
|
|
Set oFunctExt = stdLambda.oFunctExt
|
|
If bSandboxExtras Or oFunctExt Is Nothing Then Set oFunctExt = CreateObject("Scripting.Dictionary")
|
|
|
|
bBound = False
|
|
tokens = Tokenise(sEquation)
|
|
iTokenIndex = 1
|
|
iOperationIndex = 0
|
|
stackSize = 0
|
|
scopeCount = 0
|
|
funcScope = 0
|
|
Call parseBlock("eof")
|
|
Call finishOperations
|
|
|
|
Case LambdaType.iBoundLambda
|
|
bBound = True
|
|
Set oBound = params(0)
|
|
vBound = params(1)
|
|
pEquation = "BOUND..."
|
|
|
|
'Function extensions
|
|
Set oFunctExt = stdLambda.oFunctExt
|
|
If bSandboxExtras Or oFunctExt Is Nothing Then Set oFunctExt = CreateObject("Scripting.Dictionary")
|
|
Case Else
|
|
Err.Raise 1, "stdLambda::Init", "No lambda with that type."
|
|
End Select
|
|
End Sub
|
|
|
|
Private Function stdICallable_Run(ParamArray params() As Variant) As Variant
|
|
If Not bBound Then
|
|
'Execute top-down parser
|
|
Call CopyVariant(stdICallable_Run, evaluate(operations, params))
|
|
Else
|
|
Call CopyVariant(stdICallable_Run, oBound.RunEx(ConcatArrays(vBound, params)))
|
|
End If
|
|
End Function
|
|
Private Function stdICallable_RunEx(ByVal params As Variant) As Variant
|
|
If Not isArray(params) Then
|
|
Err.Raise 1, "params to be supplied as array of arguments", ""
|
|
End If
|
|
|
|
If Not bBound Then
|
|
'Execute top-down parser
|
|
Call CopyVariant(stdICallable_RunEx, evaluate(operations, params))
|
|
Else
|
|
Call CopyVariant(stdICallable_RunEx, oBound.RunEx(ConcatArrays(vBound, params)))
|
|
End If
|
|
End Function
|
|
|
|
Function Run(ParamArray params() As Variant) As Variant
|
|
If Not bBound Then
|
|
'Execute top-down parser
|
|
Call CopyVariant(Run, evaluate(operations, params))
|
|
Else
|
|
Call CopyVariant(Run, oBound.RunEx(ConcatArrays(vBound, params)))
|
|
End If
|
|
End Function
|
|
|
|
Function RunEx(ByVal params As Variant) As Variant
|
|
If Not bBound Then
|
|
If Not isArray(params) Then
|
|
Err.Raise 1, "params to be supplied as array of arguments", ""
|
|
End If
|
|
|
|
'Execute top-down parser
|
|
Call CopyVariant(RunEx, evaluate(operations, params))
|
|
Else
|
|
Call CopyVariant(RunEx, oBound.RunEx(ConcatArrays(vBound, params)))
|
|
End If
|
|
End Function
|
|
|
|
'Bind a parameter to the function
|
|
Private Function stdICallable_Bind(ParamArray params() As Variant) As stdICallable
|
|
Set stdICallable_Bind = BindEx(params)
|
|
End Function
|
|
Public Function Bind(ParamArray params() As Variant) As stdLambda
|
|
Set Bind = BindEx(params)
|
|
End Function
|
|
|
|
'Low-dependency function calling
|
|
'@protected
|
|
'@param {ByVal String} - Message to send
|
|
'@param {ByRef Boolean} - Success of message. If message wasn't processed return false.
|
|
'@param {Paramarray Variant} - Parameters to pass along with message
|
|
'@returns {Variant} - Anything returned by the function
|
|
Private Function stdICallable_SendMessage(ByVal sMessage As String, ByRef success As Boolean, ByVal params As Variant) As Variant
|
|
Select Case sMessage
|
|
Case "obj"
|
|
Set stdICallable_SendMessage = Me
|
|
success = True
|
|
Case "className"
|
|
stdICallable_SendMessage = "stdLambda"
|
|
success = True
|
|
Case "bindGlobal"
|
|
'Bind global based whether this is a bound lambda or not
|
|
Call BindGlobal(params(0), params(1))
|
|
success = True
|
|
Case Else
|
|
success = False
|
|
End Select
|
|
End Function
|
|
|
|
'================
|
|
'
|
|
' TOKENISATION
|
|
'
|
|
'================
|
|
|
|
|
|
'Tokeniser helpers
|
|
Private Function getTokenDefinitions() As TokenDefinition()
|
|
Dim arr() As TokenDefinition
|
|
ReDim arr(1 To 99)
|
|
|
|
Dim i As Long: i = 0
|
|
'Whitespace
|
|
i = i + 1: arr(i) = getTokenDefinition("space", "\s+") 'String
|
|
|
|
'Literal
|
|
i = i + 1: arr(i) = getTokenDefinition("literalString", """(?:""""|[^""])*""") 'String
|
|
i = i + 1: arr(i) = getTokenDefinition("literalNumber", "\d+(?:\.\d+)?") 'Number
|
|
i = i + 1: arr(i) = getTokenDefinition("literalBoolean", "True|False", isKeyword:=True)
|
|
|
|
'Named operators
|
|
i = i + 1: arr(i) = getTokenDefinition("is", "is", isKeyword:=True)
|
|
i = i + 1: arr(i) = getTokenDefinition("mod", "mod", isKeyword:=True)
|
|
i = i + 1: arr(i) = getTokenDefinition("and", "and", isKeyword:=True)
|
|
i = i + 1: arr(i) = getTokenDefinition("or", "or", isKeyword:=True)
|
|
i = i + 1: arr(i) = getTokenDefinition("xor", "xor", isKeyword:=True)
|
|
i = i + 1: arr(i) = getTokenDefinition("not", "not", isKeyword:=True)
|
|
i = i + 1: arr(i) = getTokenDefinition("like", "like", isKeyword:=True)
|
|
|
|
'Structural
|
|
' Inline if
|
|
i = i + 1: arr(i) = getTokenDefinition("if", "if", isKeyword:=True)
|
|
i = i + 1: arr(i) = getTokenDefinition("then", "then", isKeyword:=True)
|
|
i = i + 1: arr(i) = getTokenDefinition("else", "else", isKeyword:=True)
|
|
i = i + 1: arr(i) = getTokenDefinition("end", "end", isKeyword:=True)
|
|
' Brackets
|
|
i = i + 1: arr(i) = getTokenDefinition("lBracket", "\(")
|
|
i = i + 1: arr(i) = getTokenDefinition("rBracket", "\)")
|
|
' Functions
|
|
i = i + 1: arr(i) = getTokenDefinition("fun", "fun", isKeyword:=True)
|
|
i = i + 1: arr(i) = getTokenDefinition("comma", ",") 'params
|
|
' Lines
|
|
i = i + 1: arr(i) = getTokenDefinition("colon", ":")
|
|
|
|
'VarName
|
|
i = i + 1: arr(i) = getTokenDefinition("arg", "\$\d+")
|
|
i = i + 1: arr(i) = getTokenDefinition("var", "[a-zA-Z][a-zA-Z0-9_]*")
|
|
|
|
'Operators
|
|
i = i + 1: arr(i) = getTokenDefinition("propertyAccess", "\.\$")
|
|
i = i + 1: arr(i) = getTokenDefinition("methodAccess", "(\.\#)")
|
|
i = i + 1: arr(i) = getTokenDefinition("fieldAccess", "\.")
|
|
i = i + 1: arr(i) = getTokenDefinition("multiply", "\*")
|
|
i = i + 1: arr(i) = getTokenDefinition("divide", "\/")
|
|
i = i + 1: arr(i) = getTokenDefinition("power", "\^")
|
|
i = i + 1: arr(i) = getTokenDefinition("add", "\+")
|
|
i = i + 1: arr(i) = getTokenDefinition("subtract", "\-")
|
|
i = i + 1: arr(i) = getTokenDefinition("equal", "\=")
|
|
i = i + 1: arr(i) = getTokenDefinition("notEqual", "\<\>")
|
|
i = i + 1: arr(i) = getTokenDefinition("greaterThanEqual", "\>\=")
|
|
i = i + 1: arr(i) = getTokenDefinition("greaterThan", "\>")
|
|
i = i + 1: arr(i) = getTokenDefinition("lessThanEqual", "\<\=")
|
|
i = i + 1: arr(i) = getTokenDefinition("lessThan", "\<")
|
|
i = i + 1: arr(i) = getTokenDefinition("concatenate", "\&")
|
|
|
|
ReDim Preserve arr(1 To i)
|
|
|
|
getTokenDefinitions = arr
|
|
End Function
|
|
|
|
'===========
|
|
'
|
|
' PARSING
|
|
'
|
|
'===========
|
|
|
|
Private Sub parseBlock(ParamArray endToken() As Variant)
|
|
Call addScope
|
|
Dim size As Integer: size = stackSize + 1
|
|
|
|
' Consume multiple lines
|
|
Dim bLoop As Boolean: bLoop = True
|
|
Do
|
|
While optConsume("colon"): Wend
|
|
Call parseStatement
|
|
|
|
For i = LBound(endToken) To UBound(endToken)
|
|
If peek(endToken(i)) Then
|
|
bLoop = False
|
|
End If
|
|
Next
|
|
Loop While bLoop
|
|
|
|
' Get rid of all extra expression results and declarations
|
|
While stackSize > size
|
|
Call addOperation(oMerge, , , -1)
|
|
Wend
|
|
scopeCount = scopeCount - 1
|
|
End Sub
|
|
|
|
Private Sub addScope()
|
|
scopeCount = scopeCount + 1
|
|
Dim scope As Long: scope = scopeCount
|
|
ReDim Preserve scopes(1 To scope)
|
|
ReDim Preserve scopesArgCount(1 To scope)
|
|
Set scopes(scope) = CreateObject("Scripting.Dictionary")
|
|
Set scopesArgCount(scope) = CreateObject("Scripting.Dictionary")
|
|
End Sub
|
|
|
|
Private Sub parseStatement()
|
|
If peek("var") And peek("equal", 2) Then
|
|
Call parseAssignment
|
|
ElseIf peek("fun") Then
|
|
Call parseFunctionDeclaration
|
|
Else
|
|
Call parseExpression
|
|
End If
|
|
End Sub
|
|
|
|
Private Sub parseExpression()
|
|
Call parseLogicPriority1
|
|
End Sub
|
|
|
|
Private Sub parseLogicPriority1() 'xor
|
|
Call parseLogicPriority2
|
|
Dim bLoop As Boolean: bLoop = True
|
|
Do
|
|
If optConsume("xor") Then
|
|
Call parseLogicPriority2
|
|
Call addOperation(oLogic, oXor, , -1)
|
|
Else
|
|
bLoop = False
|
|
End If
|
|
Loop While bLoop
|
|
End Sub
|
|
|
|
Private Sub parseLogicPriority2() 'or
|
|
Call parseLogicPriority3
|
|
Dim bLoop As Boolean: bLoop = True
|
|
Do
|
|
If optConsume("or") Then
|
|
Call parseLogicPriority3
|
|
Call addOperation(oLogic, oOr, , -1)
|
|
Else
|
|
bLoop = False
|
|
End If
|
|
Loop While bLoop
|
|
End Sub
|
|
|
|
Private Sub parseLogicPriority3() 'and
|
|
Call parseLogicPriority4
|
|
Dim bLoop As Boolean: bLoop = True
|
|
Do
|
|
If optConsume("and") Then
|
|
Call parseLogicPriority4
|
|
Call addOperation(oLogic, oAnd, , -1)
|
|
Else
|
|
bLoop = False
|
|
End If
|
|
Loop While bLoop
|
|
End Sub
|
|
|
|
Private Sub parseLogicPriority4() 'not
|
|
Dim invert As Variant: invert = vbNull
|
|
While optConsume("not")
|
|
If invert = vbNull Then invert = False
|
|
invert = Not invert
|
|
Wend
|
|
|
|
Call parseComparisonPriority1
|
|
|
|
If invert <> vbNull Then
|
|
Call addOperation(oLogic, oNot)
|
|
If invert = False Then
|
|
Call addOperation(oLogic, oNot)
|
|
End If
|
|
End If
|
|
End Sub
|
|
|
|
Private Sub parseComparisonPriority1() '=, <>, <, <=, >, >=, is, Like
|
|
Call parseArithmeticPriority1
|
|
Dim bLoop As Boolean: bLoop = True
|
|
Do
|
|
If optConsume("lessThan") Then
|
|
Call parseArithmeticPriority1
|
|
Call addOperation(oComparison, oLt, , -1)
|
|
ElseIf optConsume("lessThanEqual") Then
|
|
Call parseArithmeticPriority1
|
|
Call addOperation(oComparison, oLte, , -1)
|
|
ElseIf optConsume("greaterThan") Then
|
|
Call parseArithmeticPriority1
|
|
Call addOperation(oComparison, oGt, , -1)
|
|
ElseIf optConsume("greaterThanEqual") Then
|
|
Call parseArithmeticPriority1
|
|
Call addOperation(oComparison, oGte, , -1)
|
|
ElseIf optConsume("equal") Then
|
|
Call parseArithmeticPriority1
|
|
Call addOperation(oComparison, oEql, , -1)
|
|
ElseIf optConsume("notEqual") Then
|
|
Call parseArithmeticPriority1
|
|
Call addOperation(oComparison, oNeq, , -1)
|
|
ElseIf optConsume("is") Then
|
|
Call parseArithmeticPriority1
|
|
Call addOperation(oComparison, oIs, , -1)
|
|
ElseIf optConsume("like") Then
|
|
Call parseArithmeticPriority1
|
|
Call addOperation(oComparison, oLike, , -1)
|
|
Else
|
|
bLoop = False
|
|
End If
|
|
Loop While bLoop
|
|
End Sub
|
|
|
|
Private Sub parseArithmeticPriority1() '&
|
|
Call parseArithmeticPriority2
|
|
Dim bLoop As Boolean: bLoop = True
|
|
Do
|
|
If optConsume("concatenate") Then
|
|
Call parseArithmeticPriority2
|
|
Call addOperation(oMisc, oCat, , -1)
|
|
Else
|
|
bLoop = False
|
|
End If
|
|
Loop While bLoop
|
|
End Sub
|
|
|
|
Private Sub parseArithmeticPriority2() '+, -
|
|
Call parseArithmeticPriority3
|
|
Dim bLoop As Boolean: bLoop = True
|
|
Do
|
|
If optConsume("add") Then
|
|
Call parseArithmeticPriority3
|
|
Call addOperation(oArithmetic, oAdd, , -1)
|
|
ElseIf optConsume("subtract") Then
|
|
Call parseArithmeticPriority3
|
|
Call addOperation(oArithmetic, oSub, , -1)
|
|
Else
|
|
bLoop = False
|
|
End If
|
|
Loop While bLoop
|
|
End Sub
|
|
|
|
|
|
Private Sub parseArithmeticPriority3() 'mod
|
|
Call parseArithmeticPriority4
|
|
Dim bLoop As Boolean: bLoop = True
|
|
Do
|
|
If optConsume("mod") Then
|
|
Call parseArithmeticPriority4
|
|
Call addOperation(oArithmetic, oMod, , -1)
|
|
Else
|
|
bLoop = False
|
|
End If
|
|
Loop While bLoop
|
|
End Sub
|
|
|
|
Private Sub parseArithmeticPriority4() '*, /
|
|
Call parseArithmeticPriority5
|
|
Dim bLoop As Boolean: bLoop = True
|
|
Do
|
|
If optConsume("multiply") Then
|
|
Call parseArithmeticPriority4
|
|
Call addOperation(oArithmetic, oMul, , -1)
|
|
ElseIf optConsume("divide") Then
|
|
Call parseArithmeticPriority4
|
|
Call addOperation(oArithmetic, oDiv, , -1)
|
|
Else
|
|
bLoop = False
|
|
End If
|
|
Loop While bLoop
|
|
End Sub
|
|
|
|
Private Sub parseArithmeticPriority5() '+, - (unary)
|
|
If optConsume("subtract") Then
|
|
Call parseArithmeticPriority5 'recurse
|
|
Call addOperation(oArithmetic, oNeg)
|
|
ElseIf optConsume("add") Then
|
|
Call parseArithmeticPriority5 'recurse
|
|
Else
|
|
Call parseArithmeticPriority6
|
|
End If
|
|
End Sub
|
|
|
|
Private Sub parseArithmeticPriority6() '^
|
|
Call parseFlowPriority1
|
|
Do
|
|
If optConsume("power") Then
|
|
Call parseArithmeticPriority6andahalf '- and + are still identity operators
|
|
Call addOperation(oArithmetic, oPow, , -1)
|
|
Else
|
|
bLoop = False
|
|
End If
|
|
Loop While bLoop
|
|
End Sub
|
|
|
|
Private Sub parseArithmeticPriority6andahalf() '+, - (unary)
|
|
If optConsume("subtract") Then
|
|
Call parseArithmeticPriority6andahalf 'recurse
|
|
Call addOperation(oArithmetic, oNeg)
|
|
ElseIf optConsume("add") Then
|
|
Call parseArithmeticPriority6andahalf 'recurse
|
|
Else
|
|
Call parseFlowPriority1
|
|
End If
|
|
End Sub
|
|
|
|
Private Sub parseFlowPriority1() 'if then else
|
|
If optConsume("if") Then
|
|
Call parseExpression
|
|
Dim skipThenJumpIndex As Integer: skipThenJumpIndex = addOperation(oJump, ifFalse, , -1)
|
|
|
|
Dim size As Integer: size = stackSize
|
|
Call consume("then")
|
|
Call parseBlock("else", "end")
|
|
Dim skipElseJumpIndex As Integer: skipElseJumpIndex = addOperation(oJump)
|
|
operations(skipThenJumpIndex).value = iOperationIndex
|
|
stackSize = size
|
|
|
|
If optConsume("end") Then
|
|
Call addOperation(oPush, , 0, 1) 'Expressions should always return a value
|
|
operations(skipElseJumpIndex).value = iOperationIndex
|
|
Else
|
|
Call consume("else")
|
|
Call parseBlock("eof", "rBracket", "end")
|
|
operations(skipElseJumpIndex).value = iOperationIndex
|
|
|
|
Call optConsume("end")
|
|
End If
|
|
Else
|
|
Call parseValuePriority1
|
|
End If
|
|
End Sub
|
|
|
|
Private Sub parseValuePriority1() 'numbers, $vars, strings, booleans, (expressions)
|
|
|
|
If peek("literalNumber") Then
|
|
Call addOperation(oPush, , CDbl(consume("literalNumber")), 1)
|
|
ElseIf peek("arg") Then
|
|
Call addOperation(oAccess, argument, val(Mid(consume("arg"), 2)), 1)
|
|
Call parseManyAccessors
|
|
ElseIf peek("literalString") Then
|
|
Call parseString
|
|
ElseIf peek("literalBoolean") Then
|
|
Call addOperation(oPush, , consume("literalBoolean") = "true", 1)
|
|
ElseIf peek("var") Then
|
|
If Not parseScopeAccess Then
|
|
Call parseFunction
|
|
End If
|
|
Call parseManyAccessors
|
|
Else
|
|
Call consume("lBracket")
|
|
Call parseExpression
|
|
Call consume("rBracket")
|
|
Call parseManyAccessors
|
|
End If
|
|
End Sub
|
|
|
|
Private Function parseFunction() As Variant
|
|
Call addOperation(oPush, , consume("var"), 1)
|
|
Dim size As Integer: size = stackSize
|
|
Call parseOptParameters
|
|
Call addOperation(oFunc)
|
|
stackSize = size
|
|
End Function
|
|
|
|
Private Sub parseManyAccessors()
|
|
Dim bLoop As Boolean: bLoop = True
|
|
Do
|
|
bLoop = False
|
|
If parseOptObjectField() Then bLoop = True
|
|
If parseOptObjectProperty() Then bLoop = True
|
|
If parseOptObjectMethod() Then bLoop = True
|
|
Loop While bLoop
|
|
End Sub
|
|
|
|
Private Function parseOptObjectField() As Boolean
|
|
parseOptObjectField = False
|
|
If optConsume("fieldAccess") Then
|
|
Dim size As Integer: size = stackSize
|
|
Call addOperation(oPush, , consume("var"), 1)
|
|
Call parseOptParameters
|
|
Call addOperation(oObject, oFieldCall)
|
|
stackSize = size
|
|
parseOptObjectField = True
|
|
End If
|
|
End Function
|
|
|
|
Private Function parseOptObjectProperty() As Boolean
|
|
parseOptObjectProperty = False
|
|
If optConsume("propertyAccess") Then
|
|
Dim size As Integer: size = stackSize
|
|
Call addOperation(oPush, , consume("var"), 1)
|
|
Call parseOptParameters
|
|
Call addOperation(oObject, oPropGet)
|
|
stackSize = size
|
|
parseOptObjectProperty = True
|
|
End If
|
|
End Function
|
|
|
|
Private Function parseOptObjectMethod() As Boolean
|
|
parseOptObjectMethod = False
|
|
If optConsume("methodAccess") Then
|
|
Dim size As Integer: size = stackSize
|
|
Call addOperation(oPush, , consume("var"), 1)
|
|
Call parseOptParameters
|
|
Call addOperation(oObject, oMethodCall)
|
|
stackSize = size
|
|
parseOptObjectMethod = True
|
|
End If
|
|
End Function
|
|
|
|
Private Function parseOptParameters() As Boolean
|
|
parseOptParameters = False
|
|
If optConsume("lBracket") Then
|
|
Dim iArgCount As Integer
|
|
While Not peek("rBracket")
|
|
If iArgCount > 0 Then
|
|
Call consume("comma")
|
|
End If
|
|
Call parseExpression
|
|
iArgCount = iArgCount + 1
|
|
Wend
|
|
Call consume("rBracket")
|
|
If iArgCount > 0 Then
|
|
Call addOperation(oPush, , iArgCount, 1)
|
|
End If
|
|
parseOptParameters = True
|
|
End If
|
|
End Function
|
|
|
|
Private Sub parseString()
|
|
Dim sRes As String: sRes = consume("literalString")
|
|
sRes = Mid(sRes, 2, Len(sRes) - 2)
|
|
sRes = Replace(sRes, """""", """")
|
|
Call addOperation(oPush, , sRes, 1)
|
|
End Sub
|
|
|
|
Private Function parseScopeAccess() As Boolean
|
|
If peek("lBracket", 2) Then
|
|
parseScopeAccess = parseFunctionAccess()
|
|
Else
|
|
parseScopeAccess = parseVariableAccess()
|
|
End If
|
|
End Function
|
|
|
|
Private Function parseVariableAccess() As Boolean
|
|
parseVariableAccess = False
|
|
Dim varName As String: varName = consume("var")
|
|
Dim offset As Long: offset = findVariable(varName)
|
|
If offset >= 0 Then
|
|
parseVariableAccess = True
|
|
Call addOperation(oAccess, , 1 + offset, 1)
|
|
Else
|
|
iTokenIndex = iTokenIndex - 1 ' Revert token consumption
|
|
End If
|
|
End Function
|
|
|
|
Private Sub parseAssignment()
|
|
Dim varName As String: varName = consume("var")
|
|
Call consume("equal")
|
|
Call parseExpression
|
|
Dim offset As Long: offset = findVariable(varName)
|
|
If offset >= 0 Then
|
|
' If the variable already existed, move the data to that pos on the stack
|
|
Call addOperation(oSet, , offset, -1)
|
|
Call addOperation(oAccess, , offset, 1) ' To keep a return value
|
|
Else
|
|
' If the variable didn't exist yet, treat this stack pos as its source
|
|
Call scopes(scopeCount).Add(varName, stackSize)
|
|
End If
|
|
End Sub
|
|
|
|
Private Function findVariable(varName As String) As Long
|
|
Dim scope As Long: scope = scopeCount
|
|
findVariable = -1
|
|
While scope > 0
|
|
If scopes(scope).Exists(varName) Then
|
|
If scope < funcScope Then
|
|
Call Throw("Can't access """ & varName & """, functions can unfortunately not access data outside their block")
|
|
ElseIf scopesArgCount(scope).Exists(varName) Then
|
|
Call Throw("Expected a variable, but found a function for name " & varName)
|
|
Else
|
|
findVariable = stackSize - scopes(scope).item(varName)
|
|
scope = 0
|
|
End If
|
|
End If
|
|
scope = scope - 1
|
|
Wend
|
|
End Function
|
|
'todo:
|
|
Private Function parseFunctionAccess() As Boolean
|
|
parseFunctionAccess = False
|
|
Dim funcName As String: funcName = consume("var")
|
|
Dim argCount As Long
|
|
Dim funcPos As Long: funcPos = findFunction(funcName, argCount)
|
|
If funcPos <> -1 Then
|
|
parseFunctionAccess = True
|
|
Dim returnPosIndex As Integer: returnPosIndex = addOperation(oPush, , , 1)
|
|
|
|
' Consume the arguments
|
|
consume ("lBracket")
|
|
Dim iArgCount As Integer
|
|
While Not peek("rBracket")
|
|
If iArgCount > 0 Then Call consume("comma")
|
|
Call parseExpression
|
|
iArgCount = iArgCount + 1
|
|
Wend
|
|
Call consume("rBracket")
|
|
If iArgCount <> argCount Then
|
|
Call Throw(argCount & " arguments should have been provided to " & funcName & " but only " & iArgCount & " were received")
|
|
End If
|
|
|
|
' Add call and return data
|
|
Call addOperation(oJump, , funcPos, -iArgCount) 'only -argCount since pushing Result and popping return pos cancel out
|
|
operations(returnPosIndex).value = iOperationIndex
|
|
Else
|
|
iTokenIndex = iTokenIndex - 1 ' Revert token consumption
|
|
End If
|
|
End Function
|
|
'todo:
|
|
Private Sub parseFunctionDeclaration()
|
|
' Create a dedicated scope for this funcion
|
|
Call addScope
|
|
Dim prevFuncScope As Long: prevFuncScope = funcScope
|
|
funcScope = scopeCount
|
|
|
|
' Add operation to skip this code in normal operation flow
|
|
Dim skipToIndex As Integer: skipToIndex = addOperation(oJump)
|
|
|
|
' Obtain the signature
|
|
Call consume("fun")
|
|
Dim funcName As String: funcName = consume("var")
|
|
Call consume("lBracket")
|
|
Dim iArgCount As Integer
|
|
While Not peek("rBracket")
|
|
If iArgCount > 0 Then Call consume("comma")
|
|
Call parseParameterDeclaration
|
|
iArgCount = iArgCount + 1
|
|
Wend
|
|
Call consume("rBracket")
|
|
|
|
' Register the function
|
|
Call scopes(scopeCount - 1).Add(funcName, iOperationIndex)
|
|
Call scopesArgCount(scopeCount - 1).Add(funcName, iArgCount)
|
|
|
|
' Obtain the body
|
|
Call parseBlock("end")
|
|
Call consume("end")
|
|
While iArgCount > 0
|
|
Call addOperation(oMerge, , , -1)
|
|
iArgCount = iArgCount - 1
|
|
Wend
|
|
Call addOperation(oReturn, withValue, , -1)
|
|
operations(skipToIndex).value = iOperationIndex
|
|
|
|
' Reset the scope
|
|
scopeCount = scopeCount - 1
|
|
funcScope = prevFuncScope
|
|
End Sub
|
|
'todo:
|
|
Private Sub parseParameterDeclaration()
|
|
Dim varName As String: varName = consume("var")
|
|
Dim offset As Long: offset = findVariable(varName)
|
|
If offset >= 0 Then
|
|
Call Throw("You can't declare multiple parameters with the same name")
|
|
Else
|
|
' Reserve a spot for this parameter, it will be pushed by the caller
|
|
stackSize = stackSize + 1
|
|
Call scopes(scopeCount).Add(varName, stackSize)
|
|
End If
|
|
End Sub
|
|
|
|
Private Function findFunction(varName As String, Optional ByRef argCount As Long) As Long
|
|
Dim scope As Long: scope = scopeCount
|
|
findFunction = -1
|
|
While scope > 0
|
|
If scopes(scope).Exists(varName) Then
|
|
If Not scopesArgCount(scope).Exists(varName) Then
|
|
Call Throw("Expected a function, but found a variable for name " & varName)
|
|
Else
|
|
findFunction = scopes(scope).item(varName)
|
|
argCount = scopesArgCount(scope).item(varName)
|
|
scope = 0
|
|
End If
|
|
End If
|
|
scope = scope - 1
|
|
Wend
|
|
End Function
|
|
|
|
|
|
'==============
|
|
'
|
|
' EVALUATION
|
|
'
|
|
'==============
|
|
|
|
'Evaluates the given list of operations
|
|
'@param {Operation()} operations The operations to evaluate
|
|
'@returns {Variant} The result of the operations
|
|
Private Function evaluate(ByRef ops() As Operation, ByVal vLastArgs As Variant) As Variant
|
|
Dim stack() As Variant
|
|
ReDim stack(0 To 5)
|
|
Dim stackPtr As Long: stackPtr = 0
|
|
|
|
Dim op As Operation
|
|
Dim v1 As Variant
|
|
Dim v2 As Variant
|
|
Dim v3 As Variant
|
|
Dim opIndex As Long: opIndex = 0
|
|
Dim opCount As Long: opCount = UBound(ops)
|
|
|
|
'If result is in performance cache then return it immediately
|
|
If bUsePerformanceCache Then
|
|
Dim sPerformanceCacheID As String: sPerformanceCacheID = getPerformanceCacheID(vLastArgs)
|
|
If pPerformanceCache.Exists(sPerformanceCacheID) Then
|
|
Call CopyVariant(evaluate, pPerformanceCache(sPerformanceCacheID))
|
|
Exit Function
|
|
End If
|
|
End If
|
|
|
|
'Evaluate operations to identify result
|
|
While opIndex <= opCount
|
|
op = ops(opIndex)
|
|
opIndex = opIndex + 1
|
|
Select Case op.Type
|
|
Case iType.oPush
|
|
Call pushV(stack, stackPtr, op.value)
|
|
'Arithmetic
|
|
Case iType.oArithmetic
|
|
v2 = popV(stack, stackPtr)
|
|
Select Case op.subType
|
|
Case ISubType.oAdd
|
|
v1 = popV(stack, stackPtr)
|
|
v3 = v1 + v2
|
|
Case ISubType.oSub
|
|
v1 = popV(stack, stackPtr)
|
|
v3 = v1 - v2
|
|
Case ISubType.oMul
|
|
v1 = popV(stack, stackPtr)
|
|
v3 = v1 * v2
|
|
Case ISubType.oDiv
|
|
v1 = popV(stack, stackPtr)
|
|
v3 = v1 / v2
|
|
Case ISubType.oPow
|
|
v1 = popV(stack, stackPtr)
|
|
v3 = v1 ^ v2
|
|
Case ISubType.oMod
|
|
v1 = popV(stack, stackPtr)
|
|
v3 = v1 Mod v2
|
|
Case ISubType.oNeg
|
|
v3 = -v2
|
|
Case Else
|
|
v3 = Empty
|
|
End Select
|
|
Call pushV(stack, stackPtr, v3)
|
|
'Comparison
|
|
Case iType.oComparison
|
|
Call CopyVariant(v2, popV(stack, stackPtr))
|
|
Call CopyVariant(v1, popV(stack, stackPtr))
|
|
If varType(v1) = vbError Or varType(v2) = vbError Then
|
|
v3 = False
|
|
Else
|
|
Select Case op.subType
|
|
Case ISubType.oEql
|
|
v3 = v1 = v2
|
|
Case ISubType.oNeq
|
|
v3 = v1 <> v2
|
|
Case ISubType.oGt
|
|
v3 = v1 > v2
|
|
Case ISubType.oGte
|
|
v3 = v1 >= v2
|
|
Case ISubType.oLt
|
|
v3 = v1 < v2
|
|
Case ISubType.oLte
|
|
v3 = v1 <= v2
|
|
Case ISubType.oLike
|
|
v3 = v1 Like v2
|
|
Case ISubType.oIs
|
|
v3 = v1 Is v2
|
|
Case Else
|
|
v3 = Empty
|
|
End Select
|
|
End If
|
|
Call pushV(stack, stackPtr, v3)
|
|
'Logic
|
|
Case iType.oLogic
|
|
v2 = popV(stack, stackPtr)
|
|
Select Case op.subType
|
|
Case ISubType.oAnd
|
|
v1 = popV(stack, stackPtr)
|
|
v3 = v1 And v2
|
|
Case ISubType.oOr
|
|
v1 = popV(stack, stackPtr)
|
|
v3 = v1 Or v2
|
|
Case ISubType.oNot
|
|
v3 = Not v2
|
|
Case ISubType.oXor
|
|
v1 = popV(stack, stackPtr)
|
|
v3 = v1 Xor v2
|
|
Case Else
|
|
v3 = Empty
|
|
End Select
|
|
Call pushV(stack, stackPtr, v3)
|
|
'Object
|
|
Case iType.oObject
|
|
Call objectCaller(stack, stackPtr, op)
|
|
'Func
|
|
Case iType.oFunc
|
|
Dim args() As Variant
|
|
args = getArgs(stack, stackPtr)
|
|
v1 = popV(stack, stackPtr)
|
|
Call pushV(stack, stackPtr, evaluateFunc(v1, args))
|
|
'Misc
|
|
Case iType.oMisc
|
|
v2 = popV(stack, stackPtr)
|
|
v1 = popV(stack, stackPtr)
|
|
Select Case op.subType
|
|
Case ISubType.oCat
|
|
v3 = v1 & v2
|
|
Case Else
|
|
v3 = Empty
|
|
End Select
|
|
Call pushV(stack, stackPtr, v3)
|
|
'Variable
|
|
Case iType.oAccess
|
|
Select Case op.subType
|
|
Case ISubType.argument
|
|
Dim iArgIndex As Long: iArgIndex = op.value + LBound(vLastArgs) - 1
|
|
If iArgIndex <= UBound(vLastArgs) Then
|
|
Call pushV(stack, stackPtr, vLastArgs(iArgIndex))
|
|
Else
|
|
Call Throw("Argument " & iArgIndex & " not supplied to Lambda.")
|
|
End If
|
|
Case Else
|
|
'HACK: bug where if stack(stackPtr-op.value) was an object, then array will become locked. Array locking occurs by compiler to try to protect
|
|
'instances when re-allocation would move the array, and thus corrupt the pointers. By copying the variant we redivert the compiler's efforts,
|
|
'but we might actually open ourselves to errors... @issue
|
|
Dim vAccessVar: Call CopyVariant(vAccessVar, stack(stackPtr - op.value))
|
|
Call pushV(stack, stackPtr, vAccessVar)
|
|
End Select
|
|
Case iType.oSet
|
|
v1 = popV(stack, stackPtr)
|
|
stack(stackPtr - op.value) = v1
|
|
'Flow
|
|
Case iType.oJump
|
|
Select Case op.subType
|
|
Case ISubType.ifTrue
|
|
v1 = popV(stack, stackPtr)
|
|
If v1 Then
|
|
opIndex = op.value
|
|
End If
|
|
Case ISubType.ifFalse
|
|
v1 = popV(stack, stackPtr)
|
|
If Not v1 Then
|
|
opIndex = op.value
|
|
End If
|
|
Case Else
|
|
opIndex = op.value
|
|
End Select
|
|
Case iType.oReturn
|
|
Select Case op.subType
|
|
Case ISubType.withValue
|
|
Call CopyVariant(v1, popV(stack, stackPtr))
|
|
opIndex = stack(stackPtr - 1)
|
|
Call CopyVariant(stack(stackPtr - 1), v1)
|
|
Case Else
|
|
opIndex = popV(stack, stackPtr)
|
|
End Select
|
|
'Data
|
|
Case iType.oMerge
|
|
Call CopyVariant(v1, popV(stack, stackPtr))
|
|
Call CopyVariant(stack(stackPtr - 1), v1)
|
|
Case iType.oPop
|
|
Call popV(stack, stackPtr)
|
|
Case Else
|
|
'End loop - This occurs when opIndex > opCount
|
|
opIndex = opCount + 1
|
|
End Select
|
|
Wend
|
|
|
|
'Add result to performance cache
|
|
If bUsePerformanceCache Then
|
|
If isObject(stack(0)) Then
|
|
Set pPerformanceCache(sPerformanceCacheID) = stack(0)
|
|
Else
|
|
Let pPerformanceCache(sPerformanceCacheID) = stack(0)
|
|
End If
|
|
End If
|
|
|
|
Call CopyVariant(evaluate, stack(0))
|
|
End Function
|
|
|
|
'Retrieves the arguments from the stack
|
|
'@param {ByRef Variant()} stack The stack to get the data from and add the result to
|
|
'@param {ByRef Long} stackPtr The pointer that indicates the position of the top of the stack
|
|
'@returns {Variant()} The args list
|
|
Private Function getArgs(ByRef stack() As Variant, ByRef stackPtr As Long) As Variant
|
|
Dim argCount As Variant: argCount = stack(stackPtr - 1)
|
|
Dim args() As Variant
|
|
If varType(argCount) = vbString Then
|
|
'If no argument count is specified, there are no arguments
|
|
argCount = 0
|
|
args = Array()
|
|
Else
|
|
'If an argument count is provided, extract all arguments into an array
|
|
Call popV(stack, stackPtr)
|
|
ReDim args(1 To argCount)
|
|
|
|
'Arguments are held on the stack in order, which means that we need to fill the array in reverse order.
|
|
For i = argCount To 1 Step -1
|
|
Call CopyVariant(args(i), popV(stack, stackPtr))
|
|
Next
|
|
End If
|
|
|
|
getArgs = args
|
|
End Function
|
|
|
|
'Calls an object method/setter/getter/letter
|
|
'@param {ByRef Variant()} stack The stack to get the data from and add the result to
|
|
'@param {ByRef Long} stackPtr The pointer that indicates the position of the top of the stack
|
|
'@param {ByRef Operation} op The operation to execute
|
|
Private Sub objectCaller(ByRef stack() As Variant, ByRef stackPtr As Long, ByRef op As Operation)
|
|
'Get the name and arguments
|
|
Dim args() As Variant: args = getArgs(stack, stackPtr)
|
|
Dim funcName As Variant: funcName = popV(stack, stackPtr)
|
|
|
|
'Get caller type
|
|
Dim callerType As VbCallType
|
|
Select Case op.subType
|
|
Case ISubType.oFieldCall: callerType = VbGet Or VbMethod
|
|
Case ISubType.oPropGet: callerType = VbGet
|
|
Case ISubType.oMethodCall: callerType = VbMethod
|
|
Case ISubType.oPropLet: callerType = VbLet
|
|
Case ISubType.oPropSet: callerType = VbSet
|
|
End Select
|
|
|
|
'Call rtcCallByName
|
|
Dim obj As Object
|
|
Set obj = popV(stack, stackPtr)
|
|
Call pushV(stack, stackPtr, stdCallByName(obj, funcName, callerType, args))
|
|
End Sub
|
|
|
|
'Calls an object method/setter/getter/letter. Treats dictionary properties as direct object properties, I.E. `A.B` ==> `A.item("B")`
|
|
'@param {ByRef Object} - The object to call
|
|
'@param {ByVal String} - The method name to call
|
|
'@param {ByVal VbCallType} - The property/method call type
|
|
'@param {ByVal Variant()} - An array of arguments. This function supports up to 30 arguments, akin to Application.Run
|
|
'@returns Variant - The return value of the called function
|
|
Public Function stdCallByName(ByRef obj As Object, ByVal funcName As String, ByVal callerType As VbCallType, ByRef args() As Variant) As Variant
|
|
'If Dictionary and
|
|
If TypeName(obj) = "Dictionary" Then
|
|
Select Case funcName
|
|
Case "add", "exists", "items", "keys", "remove", "removeall", "comparemode", "count", "item", "key"
|
|
'These methods already exist on dictionary, do not override
|
|
Case Else
|
|
'Call DictionaryInstance.Item(funcName) only if funcName exists on the item
|
|
If obj.Exists(funcName) Then
|
|
'TODO: Make this work for callerType.VbLet
|
|
Call CopyVariant(stdCallByName, obj.item(funcName))
|
|
Exit Function
|
|
End If
|
|
End Select
|
|
End If
|
|
|
|
'Call CallByName from DLL or
|
|
#If Mac Then
|
|
Call CopyVariant(stdCallByName, macCallByName(obj, funcName, callerType, args))
|
|
#Else
|
|
'TODO: Better error handling (property or method <funcName> doesn't exist on object with type <typename(obj)>)
|
|
On Error GoTo ErrorInRTCCallByName
|
|
Call CopyVariant(stdCallByName, rtcCallByName(obj, StrPtr(funcName), callerType, args, &H409))
|
|
#End If
|
|
Exit Function
|
|
ErrorInRTCCallByName:
|
|
'HACK: Rarely objects which are poorly implemented might throw missing member errors. This can for instance happen with RecordSet. This try loop is an attempt to catch this
|
|
Dim iTry As Long: iTry = iTry + 1
|
|
If iTry < 5 Then
|
|
Dim sCallerTypeName As String
|
|
Select Case callerType
|
|
Case VbGet Or VbMethod: sCallerTypeName = "Property or Method "
|
|
Case VbGet: sCallerTypeName = "Property "
|
|
Case VbMethod: sCallerTypeName = "Method "
|
|
End Select
|
|
Err.Raise Err.Number, "", sCallerTypeName & funcName & " doesn't exist on object with type " & TypeName(obj)
|
|
Resume
|
|
Else
|
|
Resume
|
|
End If
|
|
End Function
|
|
|
|
'Evaluates the built in standard functions
|
|
'@param {String} sFuncName The name of the function to invoke
|
|
'@param {Variant} args() The arguments
|
|
'@returns The result
|
|
Private Function evaluateFunc(ByVal sFuncName As String, ByVal args As Variant) As Variant
|
|
Dim iArgStart As Long: iArgStart = LBound(args)
|
|
If TypeName(oFunctExt) = "Dictionary" Then
|
|
If oFunctExt.Exists(sFuncName) Then
|
|
Dim vInjectedVar As Variant
|
|
Call CopyVariant(vInjectedVar, oFunctExt(sFuncName))
|
|
If TypeOf vInjectedVar Is stdICallable Then
|
|
Call CopyVariant(evaluateFunc, oFunctExt(sFuncName).RunEx(args))
|
|
Else
|
|
Call CopyVariant(evaluateFunc, vInjectedVar)
|
|
End If
|
|
Exit Function
|
|
End If
|
|
End If
|
|
|
|
Select Case LCase(sFuncName)
|
|
'Useful OOP constants
|
|
Case "thisworkbook": If isObject(ThisWorkbook) Then Set evaluateFunc = ThisWorkbook
|
|
Case "application": If isObject(Application) Then Set evaluateFunc = Application
|
|
|
|
'Data structures
|
|
Case "dict":
|
|
Dim oRetDict As Object: Set oRetDict = CreateObject("Scripting.Dictionary")
|
|
For i = iArgStart To UBound(args) Step 2
|
|
Call oRetDict.Add(args(i), args(i + 1))
|
|
Next
|
|
Set evaluateFunc = oRetDict
|
|
|
|
'MATH:
|
|
'-----
|
|
Case "abs": evaluateFunc = VBA.Math.Abs(args(iArgStart))
|
|
Case "int": evaluateFunc = VBA.Int(args(iArgStart))
|
|
Case "fix": evaluateFunc = VBA.Fix(args(iArgStart))
|
|
Case "exp": evaluateFunc = VBA.Math.Exp(args(iArgStart))
|
|
Case "log": evaluateFunc = VBA.Math.Log(args(iArgStart))
|
|
Case "sqr": evaluateFunc = VBA.Math.Sqr(args(iArgStart))
|
|
Case "sgn": evaluateFunc = VBA.Math.Sgn(args(iArgStart))
|
|
Case "rnd": evaluateFunc = VBA.Math.Rnd(args(iArgStart))
|
|
|
|
'Trigonometry
|
|
Case "cos": evaluateFunc = VBA.Math.Cos(args(iArgStart))
|
|
Case "sin": evaluateFunc = VBA.Math.Sin(args(iArgStart))
|
|
Case "tan": evaluateFunc = VBA.Math.Tan(args(iArgStart))
|
|
Case "atn": evaluateFunc = VBA.Math.Atn(args(iArgStart))
|
|
Case "asin": evaluateFunc = VBA.Math.Atn(args(iArgStart) / VBA.Math.Sqr(-1 * args(iArgStart) * args(iArgStart) + 1))
|
|
Case "acos": evaluateFunc = VBA.Math.Atn(-1 * args(iArgStart) / VBA.Math.Sqr(-1 * args(iArgStart) * args(iArgStart) + 1)) + 2 * Atn(1)
|
|
|
|
'VBA Constants:
|
|
Case "vbcrlf": evaluateFunc = vbCrLf
|
|
Case "vbcr": evaluateFunc = vbCr
|
|
Case "vblf": evaluateFunc = vbLf
|
|
Case "vbnewline": evaluateFunc = vbNewLine
|
|
Case "vbnullchar": evaluateFunc = vbNullChar
|
|
Case "vbnullstring": evaluateFunc = vbNullString
|
|
Case "vbobjecterror": evaluateFunc = vbObjectError
|
|
Case "vbtab": evaluateFunc = vbTab
|
|
Case "vbback": evaluateFunc = vbBack
|
|
Case "vbformfeed": evaluateFunc = vbFormFeed
|
|
Case "vbverticaltab": evaluateFunc = vbVerticalTab
|
|
Case "null": evaluateFunc = Null
|
|
Case "nothing": Set evaluateFunc = Nothing
|
|
Case "empty": evaluateFunc = Empty
|
|
Case "missing": evaluateFunc = GetMissing()
|
|
|
|
'VBA Structure
|
|
Case "array": evaluateFunc = args
|
|
'TODO: Case "callbyname": evaluateFunc = CallByName(args(iArgStart))
|
|
Case "createobject"
|
|
Select Case UBound(args)
|
|
Case iArgStart
|
|
Set evaluateFunc = CreateObject(args(iArgStart))
|
|
Case iArgStart + 1
|
|
Set evaluateFunc = CreateObject(args(iArgStart), args(iArgStart + 1))
|
|
End Select
|
|
Case "getobject"
|
|
Select Case UBound(args)
|
|
Case iArgStart
|
|
Set evaluateFunc = GetObject(args(iArgStart))
|
|
Case iArgStart + 1
|
|
Set evaluateFunc = GetObject(args(iArgStart), args(iArgStart + 1))
|
|
End Select
|
|
Case "iff"
|
|
If CBool(args(iArgStart)) Then
|
|
evaluateFunc = args(iArgStart + 1)
|
|
Else
|
|
evaluateFunc = args(iArgStart + 2)
|
|
End If
|
|
Case "typename"
|
|
evaluateFunc = TypeName(args(iArgStart))
|
|
|
|
'VBA Casting
|
|
Case "cbool": evaluateFunc = VBA.Conversion.CBool(args(iArgStart))
|
|
Case "cbyte": evaluateFunc = VBA.Conversion.CByte(args(iArgStart))
|
|
Case "ccur": evaluateFunc = VBA.Conversion.CCur(args(iArgStart))
|
|
Case "cdate": evaluateFunc = VBA.Conversion.CDate(args(iArgStart))
|
|
Case "csng": evaluateFunc = VBA.Conversion.CSng(args(iArgStart))
|
|
Case "cdbl": evaluateFunc = VBA.Conversion.CDbl(args(iArgStart))
|
|
Case "cint": evaluateFunc = VBA.Conversion.CInt(args(iArgStart))
|
|
Case "clng": evaluateFunc = VBA.Conversion.CLng(args(iArgStart))
|
|
Case "cstr": evaluateFunc = VBA.Conversion.CStr(args(iArgStart))
|
|
Case "cvar": evaluateFunc = VBA.Conversion.CVar(args(iArgStart))
|
|
Case "cverr": evaluateFunc = VBA.Conversion.CVErr(args(iArgStart))
|
|
|
|
'Conversion
|
|
Case "asc": evaluateFunc = VBA.Asc(args(iArgStart))
|
|
Case "chr": evaluateFunc = VBA.Chr(args(iArgStart))
|
|
|
|
Case "format"
|
|
Select Case UBound(args)
|
|
Case iArgStart
|
|
evaluateFunc = Format(args(iArgStart))
|
|
Case iArgStart + 1
|
|
evaluateFunc = Format(args(iArgStart), args(iArgStart + 1))
|
|
Case iArgStart + 2
|
|
evaluateFunc = Format(args(iArgStart), args(iArgStart + 1), args(iArgStart + 2))
|
|
Case iArgStart + 3
|
|
evaluateFunc = Format(args(iArgStart), args(iArgStart + 1), args(iArgStart + 2), args(iArgStart + 3))
|
|
End Select
|
|
Case "hex": evaluateFunc = VBA.Conversion.Hex(args(iArgStart))
|
|
Case "oct": evaluateFunc = VBA.Conversion.Oct(args(iArgStart))
|
|
Case "str": evaluateFunc = VBA.Conversion.Str(args(iArgStart))
|
|
Case "val": evaluateFunc = VBA.Conversion.val(args(iArgStart))
|
|
|
|
'String functions
|
|
Case "trim": evaluateFunc = VBA.Trim(args(iArgStart))
|
|
Case "lcase": evaluateFunc = VBA.LCase(args(iArgStart))
|
|
Case "ucase": evaluateFunc = VBA.UCase(args(iArgStart))
|
|
Case "right": evaluateFunc = VBA.right(args(iArgStart), args(iArgStart + 1))
|
|
Case "left": evaluateFunc = VBA.Left(args(iArgStart), args(iArgStart + 1))
|
|
Case "len": evaluateFunc = VBA.Len(args(iArgStart))
|
|
|
|
Case "mid"
|
|
Select Case UBound(args)
|
|
Case iArgStart + 1
|
|
evaluateFunc = VBA.Mid(args(iArgStart), args(iArgStart + 1))
|
|
Case iArgStart + 2
|
|
evaluateFunc = VBA.Mid(args(iArgStart), args(iArgStart + 1), args(iArgStart + 2))
|
|
End Select
|
|
'Misc
|
|
Case "now": evaluateFunc = VBA.DateTime.Now()
|
|
Case "switch"
|
|
'TODO: Switch caching and use of dictionary would be good here
|
|
For i = iArgStart + 1 To UBound(args) Step 2
|
|
If i + 1 > UBound(args) Then
|
|
Call CopyVariant(evaluateFunc, args(i))
|
|
Exit For
|
|
Else
|
|
If isObject(args(iArgStart)) And isObject(args(i)) Then
|
|
If args(iArgStart) Is args(i) Then
|
|
Set evaluateFunc = args(i + 1)
|
|
Exit For
|
|
End If
|
|
ElseIf (Not isObject(args(iArgStart))) And (Not isObject(args(i))) Then
|
|
If args(iArgStart) = args(i) Then
|
|
evaluateFunc = args(i + 1)
|
|
Exit For
|
|
End If
|
|
End If
|
|
End If
|
|
Next
|
|
Case "any"
|
|
evaluateFunc = False
|
|
'Detect if comparee is an object or a value
|
|
If isObject(args(iArgStart)) Then
|
|
For i = iArgStart + 1 To UBound(args)
|
|
If isObject(args(i)) Then
|
|
If args(iArgStart) Is args(i) Then
|
|
evaluateFunc = True
|
|
Exit For
|
|
End If
|
|
End If
|
|
Next
|
|
Else
|
|
For i = iArgStart + 1 To UBound(args)
|
|
If Not isObject(args(i)) Then
|
|
If args(iArgStart) = args(i) Then
|
|
evaluateFunc = True
|
|
Exit For
|
|
End If
|
|
End If
|
|
Next
|
|
End If
|
|
Case "eval": evaluateFunc = stdLambda.Create(args(iArgStart)).Run()
|
|
Case "lambda": Set evaluateFunc = stdLambda.Create(args(iArgStart))
|
|
Case "isnumeric": evaluateFunc = isNumeric(args(iArgStart))
|
|
Case "isobject": evaluateFunc = isObject(args(iArgStart))
|
|
Case Else
|
|
Call Throw("No such function: " & sFuncName)
|
|
End Select
|
|
End Function
|
|
|
|
'==========================
|
|
'
|
|
' General helper methods
|
|
'
|
|
'==========================
|
|
|
|
'Class initialisation
|
|
Private Sub Class_Initialize()
|
|
'If this is stdLambda predeclared class, ensure that oFuncExt is defined.
|
|
If Me Is stdLambda Then Set oFuncExt = CreateObject("Scripting.Dictionary")
|
|
End Sub
|
|
|
|
'------------
|
|
'tokenisation
|
|
'------------
|
|
|
|
'Tokenise the input string
|
|
'@param {string} sInput String to tokenise
|
|
'@return {token[]} A list of Token structs
|
|
Private Function Tokenise(ByVal sInput As String) As token()
|
|
Dim defs() As TokenDefinition
|
|
defs = getTokenDefinitions()
|
|
|
|
Dim tokens() As token, iTokenDef As Long
|
|
ReDim tokens(1 To 1)
|
|
|
|
Dim sInputOld As String
|
|
sInputOld = sInput
|
|
|
|
Dim iNumTokens As Long
|
|
iNumTokens = 0
|
|
While Len(sInput) > 0
|
|
Dim bMatched As Boolean
|
|
bMatched = False
|
|
|
|
For iTokenDef = 1 To UBound(defs)
|
|
'Test match, if matched then add token
|
|
If defs(iTokenDef).RegexObj.test(sInput) Then
|
|
'Get match details
|
|
Dim oMatch As Object: Set oMatch = defs(iTokenDef).RegexObj.Execute(sInput)
|
|
|
|
'Create new token
|
|
iNumTokens = iNumTokens + 1
|
|
ReDim Preserve tokens(1 To iNumTokens)
|
|
|
|
'Tokenise
|
|
tokens(iNumTokens).Type = defs(iTokenDef)
|
|
tokens(iNumTokens).value = oMatch(0)
|
|
|
|
'Trim string to unmatched range
|
|
sInput = Mid(sInput, Len(oMatch(0)) + 1)
|
|
|
|
'Flag that a match was made
|
|
bMatched = True
|
|
Exit For
|
|
End If
|
|
Next
|
|
|
|
'If no match made then syntax error
|
|
If Not bMatched Then
|
|
Call Throw("Syntax Error unexpected character """ & Mid(sInput, 1, 1) & """")
|
|
End If
|
|
Wend
|
|
|
|
'Add eof token
|
|
ReDim Preserve tokens(1 To iNumTokens + 1)
|
|
tokens(iNumTokens + 1).Type.name = "eof"
|
|
|
|
Tokenise = removeTokens(tokens, "space")
|
|
End Function
|
|
|
|
'Obtains a TokenDefinition from input params
|
|
'@param {ByVal String} The name of the token
|
|
'@param {ByVal String} The regex pattern to match durin tokenisation
|
|
'@param {ByVal Boolean?=True} Should this token ignoreCase?
|
|
'@param {ByVal Boolean?=False} Is this token a keyword?
|
|
'@returns {TokenDefinition} The definition of the token
|
|
Private Function getTokenDefinition(ByVal sName As String, ByVal sRegex As String, Optional ByVal ignoreCase As Boolean = True, Optional ByVal isKeyword As Boolean = False) As TokenDefinition
|
|
getTokenDefinition.name = sName
|
|
getTokenDefinition.Regex = sRegex & IIf(isKeyword, "\b", "")
|
|
Set getTokenDefinition.RegexObj = CreateObject("VBScript.Regexp")
|
|
getTokenDefinition.RegexObj.Pattern = "^(?:" & sRegex & IIf(isKeyword, "\b", "") & ")"
|
|
getTokenDefinition.RegexObj.ignoreCase = ignoreCase
|
|
End Function
|
|
|
|
'Copies one variant to a destination
|
|
'@param {ByRef Token()} tokens Tokens to remove the specified type from
|
|
'@param {string} sRemoveType Token type to remove.
|
|
'@returns {Token()} The modified token array.
|
|
Private Function removeTokens(ByRef tokens() As token, ByVal sRemoveType As String) As token()
|
|
Dim iCountRemoved As Long: iCountRemoved = 0
|
|
Dim iToken As Long
|
|
For iToken = LBound(tokens) To UBound(tokens)
|
|
If tokens(iToken).Type.name <> sRemoveType Then
|
|
tokens(iToken - iCountRemoved) = tokens(iToken)
|
|
Else
|
|
iCountRemoved = iCountRemoved + 1
|
|
End If
|
|
Next
|
|
ReDim Preserve tokens(LBound(tokens) To (UBound(tokens) - iCountRemoved))
|
|
removeTokens = tokens
|
|
End Function
|
|
|
|
'-------
|
|
'parsing
|
|
'-------
|
|
|
|
'Shifts the Tokens array (uses an index)
|
|
'@returns {token} The token at the tokenIndex
|
|
Private Function ShiftTokens() As token
|
|
If iTokenIndex = 0 Then iTokenIndex = 1
|
|
|
|
'Get next token
|
|
ShiftTokens = tokens(iTokenIndex)
|
|
|
|
'Increment token index
|
|
iTokenIndex = iTokenIndex + 1
|
|
End Function
|
|
|
|
' Consumes a token
|
|
' @param {string} token The token type name to consume
|
|
' @throws If the expected token wasn't found
|
|
' @returns {string} The value of the token
|
|
Private Function consume(ByVal sType As String) As String
|
|
Dim firstToken As token
|
|
firstToken = ShiftTokens()
|
|
If firstToken.Type.name <> sType Then
|
|
Call Throw("Unexpected token, found: " & firstToken.Type.name & " but expected: " & sType)
|
|
Else
|
|
consume = firstToken.value
|
|
End If
|
|
End Function
|
|
|
|
'Checks whether the token at iTokenIndex is of the given type
|
|
'@param {string} token The token that is expected
|
|
'@param {long} offset The number of tokens to look into the future, defaults to 1
|
|
'@returns {boolean} Whether the expected token was found
|
|
Private Function peek(ByVal sTokenType As String, Optional offset As Long = 1) As Boolean
|
|
If iTokenIndex = 0 Then iTokenIndex = 1
|
|
If iTokenIndex + offset - 1 <= UBound(tokens) Then
|
|
peek = tokens(iTokenIndex + offset - 1).Type.name = sTokenType
|
|
Else
|
|
peek = False
|
|
End If
|
|
End Function
|
|
|
|
' Combines peek and consume, consuming a token only if matched, without throwing an error if not
|
|
' @param {string} token The token that is expected
|
|
' @returns {vbNullString|string} Whether the expected token was found
|
|
Private Function optConsume(ByVal sTokenType As String) As Boolean
|
|
Dim matched As Boolean: matched = peek(sTokenType)
|
|
If matched Then
|
|
Call consume(sTokenType)
|
|
End If
|
|
optConsume = matched
|
|
End Function
|
|
|
|
'Checks the value of the passed parameter, to check if it is the unique constant
|
|
'@param {Variant} test The value to test. May be an object or literal value
|
|
'@returns {Boolean} True if the value is the unique constant, otherwise false
|
|
Private Function isUniqueConst(ByRef test As Variant) As Boolean
|
|
If Not isObject(test) Then
|
|
If varType(test) = vbString Then
|
|
If test = UniqueConst Then
|
|
isUniqueConst = True
|
|
Exit Function
|
|
End If
|
|
End If
|
|
End If
|
|
isUniqueConst = False
|
|
End Function
|
|
|
|
'Adds an operation to the instance operations list
|
|
'@param {IType} kType The main type of the operation
|
|
'@param {ISubType} subType The sub type of the operation
|
|
'@param {Variant} value The value associated with the operation
|
|
'@param {Integer} stackDelta The effect this has on the stack size (increasing or decreasing it)
|
|
'@returns {Integer} The index of the created operation
|
|
Private Function addOperation(kType As iType, Optional subType As ISubType, Optional value As Variant, Optional stackDelta As Integer) As Integer
|
|
If iOperationIndex = 0 Then
|
|
ReDim Preserve operations(0 To 1)
|
|
Else
|
|
Dim size As Long: size = UBound(operations)
|
|
If iOperationIndex > size Then
|
|
ReDim Preserve operations(0 To size * 2)
|
|
End If
|
|
End If
|
|
|
|
With operations(iOperationIndex)
|
|
.Type = kType
|
|
.subType = subType
|
|
Call CopyVariant(.value, value)
|
|
End With
|
|
addOperation = iOperationIndex
|
|
stackSize = stackSize + stackDelta
|
|
|
|
iOperationIndex = iOperationIndex + 1
|
|
End Function
|
|
|
|
'Resizes the operations list so there are no more empty operations
|
|
Private Sub finishOperations()
|
|
ReDim Preserve operations(0 To iOperationIndex)
|
|
End Sub
|
|
|
|
'----------
|
|
'evaluation
|
|
'----------
|
|
|
|
Private Sub pushV(ByRef stack() As Variant, ByRef index As Long, ByVal item As Variant)
|
|
Dim size As Long: size = UBound(stack)
|
|
If index > size Then
|
|
ReDim Preserve stack(0 To size * 2)
|
|
End If
|
|
If isObject(item) Then
|
|
Set stack(index) = item
|
|
Else
|
|
stack(index) = item
|
|
End If
|
|
index = index + 1
|
|
End Sub
|
|
|
|
Private Function popV(ByRef stack() As Variant, ByRef index As Variant) As Variant
|
|
Dim size As Long: size = UBound(stack)
|
|
If index < size / 3 And index > minStackSize Then
|
|
ReDim Preserve stack(0 To CLng(size / 2))
|
|
End If
|
|
index = index - 1
|
|
If isObject(stack(index)) Then
|
|
Set popV = stack(index)
|
|
Else
|
|
popV = stack(index)
|
|
End If
|
|
#If devMode Then
|
|
stack(index) = Empty
|
|
#End If
|
|
End Function
|
|
|
|
'Serializes the argument array passed to a string.
|
|
'@param {ByRef Variant()} Arguments to serialize
|
|
'@returns {String} Serialized representation of the arguments.
|
|
'@remark Objects cannot be split into their components and thus are cached as a conglomerate of type and pointer (e.g. Dictionary<12341234123>).
|
|
'@TODO: Potentially use [StgSerializePropVariant ](https://docs.microsoft.com/en-us/windows/win32/api/propvarutil/nf-propvarutil-stgserializepropvariant) as this'd be more optimal
|
|
'@example
|
|
' Debug.Print getPerformanceCacheID(Array())=""
|
|
' Debug.Print getPerformanceCacheID(Array(Array(1, 2, Null), "yop", Empty, "", Nothing, New Collection, DateSerial(2020, 1, 1), False, True)) = "Array[1;2;null;];""yop"";empty;"""";Nothing;Collection<1720260481920>;01/01/2020;False;True;"
|
|
'returns
|
|
' True
|
|
' True
|
|
Private Function getPerformanceCacheID(ByRef Arguments As Variant) As String
|
|
Dim Length As Long: Length = UBound(Arguments) - LBound(Arguments) + 1
|
|
If Length > 0 Then
|
|
Dim sSerialized As String: sSerialized = ""
|
|
For i = LBound(Arguments) To UBound(Arguments)
|
|
Select Case varType(Arguments(i))
|
|
Case vbBoolean, vbByte, vbInteger, vbLong, vbLongLong, vbCurrency, vbDate, vbDecimal, vbDouble, vbSingle
|
|
sSerialized = sSerialized & Arguments(i) & ";"
|
|
Case vbString
|
|
sSerialized = sSerialized & """" & Arguments(i) & """;"
|
|
Case vbObject, vbDataObject
|
|
If Arguments(i) Is Nothing Then
|
|
sSerialized = sSerialized & "Nothing;"
|
|
Else
|
|
sSerialized = sSerialized & TypeName(Arguments(i)) & "<" & ObjPtr(Arguments(i)) & ">;"
|
|
End If
|
|
Case vbEmpty
|
|
sSerialized = sSerialized & "empty;"
|
|
Case vbNull
|
|
sSerialized = sSerialized & "null;"
|
|
Case vbError
|
|
sSerialized = sSerialized & "error;"
|
|
Case Else
|
|
If CBool(varType(Arguments(i)) And vbArray) Then
|
|
sSerialized = sSerialized & "Array[" & getPerformanceCacheID(Arguments(i)) & "];"
|
|
Else
|
|
sSerialized = sSerialized & "Unknown;"
|
|
End If
|
|
End Select
|
|
Next
|
|
End If
|
|
getPerformanceCacheID = sSerialized
|
|
End Function
|
|
|
|
'-------
|
|
'general
|
|
'-------
|
|
|
|
'Used to obtain missing
|
|
'@Param {Variant} The value to be returned - Please do not populate this parameter.
|
|
'@returns {Missing} Missing value
|
|
Private Function GetMissing(Optional arg As Variant) As Variant
|
|
GetMissing = arg
|
|
End Function
|
|
|
|
'Copies one variant to a destination
|
|
'@param {ByRef Variant} dest Destination to copy variant to
|
|
'@param {Variant} value Source to copy variant from.
|
|
'@perf This appears to be a faster variant of "oleaut32.dll\VariantCopy" + it's multi-platform
|
|
Private Sub CopyVariant(ByRef dest As Variant, ByVal value As Variant)
|
|
If isObject(value) Then
|
|
Set dest = value
|
|
Else
|
|
Let dest = value
|
|
End If
|
|
End Sub
|
|
|
|
|
|
'TODO: Better error handling
|
|
'Throws an error
|
|
'@param {string} The error message to be thrown
|
|
'@returns {void}
|
|
Private Sub Throw(ByVal sMessage As String)
|
|
Err.Raise 1, "stdLambda", sMessage, vbCritical
|
|
End
|
|
End Sub
|
|
|
|
|
|
'Used by Bind() for binding arguments ontop of BoundArgs and binding bound args to passed arguments
|
|
'@param {Variant()} The 1st array which will
|
|
'@param {Variant()} The 2nd array which will be concatenated after the 1st
|
|
'@complexity O(1)
|
|
Private Function ConcatArrays(ByVal Arr1 As Variant, ByVal Arr2 As Variant) As Variant
|
|
Dim ub1 As Long: ub1 = UBound(Arr1)
|
|
Dim lb1 As Long: lb1 = LBound(Arr1)
|
|
Dim ub2 As Long: ub2 = UBound(Arr2)
|
|
Dim lb2 As Long: lb2 = LBound(Arr2)
|
|
Dim iub As Long: iub = ub1 + ub2 - lb2 + 1
|
|
|
|
If iub > -1 Then
|
|
Dim v() As Variant
|
|
ReDim v(lb1 To iub)
|
|
|
|
|
|
Dim i As Long
|
|
For i = LBound(v) To UBound(v)
|
|
If i <= ub1 Then
|
|
Call CopyVariant(v(i), Arr1(i))
|
|
Else
|
|
Call CopyVariant(v(i), Arr2(i - ub1 - 1 + lb2))
|
|
End If
|
|
Next
|
|
ConcatArrays = v
|
|
Else
|
|
ConcatArrays = Array()
|
|
End If
|
|
End Function
|
|
|
|
|
|
|
|
'----------
|
|
'evaluation Mac
|
|
'----------
|
|
|
|
'Reimplementation of rtcCallByName() but for Mac OS
|
|
'@param {ByRef Object} - The object to call
|
|
'@param {ByVal String} - The method name to call
|
|
'@param {ByVal VbCallType} - The property/method call type
|
|
'@param {ByVal Variant()} - An array of arguments. This function supports up to 30 arguments, akin to Application.Run
|
|
'@returns Variant - The return value of the called function
|
|
Private Function macCallByName(ByRef obj As Object, ByVal funcName As String, ByVal callerType As VbCallType, ByVal args As Variant) As Variant
|
|
'Get currentLength
|
|
Dim currentLength As Integer: currentLength = UBound(args) - LBound(args) + 1
|
|
Dim i As Long: i = LBound(args)
|
|
|
|
'Cant use same trick as in stdCallback, as it seems CallByName doesn't support the Missing value... So have to do it this way...
|
|
'Will go up to 30 as per Application.Run() Also seems that you can't pass args array directly to CallByName() because it causes an Overflow error,
|
|
'instead we need to convert the args to vars first... Yes this doesn't look at all pretty, but at least it's compartmentalised to the end of the code...
|
|
Dim a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28, a29
|
|
If currentLength - 1 >= 0 Then Call CopyVariant(a0, args(i + 0)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 1 Then Call CopyVariant(a1, args(i + 1)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 2 Then Call CopyVariant(a2, args(i + 2)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 3 Then Call CopyVariant(a3, args(i + 3)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 4 Then Call CopyVariant(a4, args(i + 4)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 5 Then Call CopyVariant(a5, args(i + 5)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 6 Then Call CopyVariant(a6, args(i + 6)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 7 Then Call CopyVariant(a7, args(i + 7)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 8 Then Call CopyVariant(a8, args(i + 8)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 9 Then Call CopyVariant(a9, args(i + 9)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 10 Then Call CopyVariant(a10, args(i + 10)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 11 Then Call CopyVariant(a11, args(i + 11)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 12 Then Call CopyVariant(a12, args(i + 12)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 13 Then Call CopyVariant(a13, args(i + 13)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 14 Then Call CopyVariant(a14, args(i + 14)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 15 Then Call CopyVariant(a15, args(i + 15)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 16 Then Call CopyVariant(a16, args(i + 16)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 17 Then Call CopyVariant(a17, args(i + 17)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 18 Then Call CopyVariant(a18, args(i + 18)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 19 Then Call CopyVariant(a19, args(i + 19)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 20 Then Call CopyVariant(a20, args(i + 20)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 21 Then Call CopyVariant(a21, args(i + 21)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 22 Then Call CopyVariant(a22, args(i + 22)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 23 Then Call CopyVariant(a23, args(i + 23)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 24 Then Call CopyVariant(a24, args(i + 24)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 25 Then Call CopyVariant(a25, args(i + 25)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 26 Then Call CopyVariant(a26, args(i + 26)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 27 Then Call CopyVariant(a27, args(i + 27)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 28 Then Call CopyVariant(a28, args(i + 28)) Else GoTo macJmpCall
|
|
If currentLength - 1 >= 29 Then Call CopyVariant(a29, args(i + 29)) Else GoTo macJmpCall
|
|
|
|
macJmpCall:
|
|
Select Case currentLength
|
|
Case 0: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType))
|
|
Case 1: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0))
|
|
Case 2: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1))
|
|
Case 3: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2))
|
|
Case 4: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3))
|
|
Case 5: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4))
|
|
Case 6: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5))
|
|
Case 7: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6))
|
|
Case 8: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7))
|
|
Case 9: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8))
|
|
Case 10: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9))
|
|
Case 11: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
|
|
Case 12: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11))
|
|
Case 13: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12))
|
|
Case 14: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13))
|
|
Case 15: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14))
|
|
Case 16: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15))
|
|
Case 17: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16))
|
|
Case 18: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17))
|
|
Case 19: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18))
|
|
Case 20: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19))
|
|
Case 21: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20))
|
|
Case 22: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21))
|
|
Case 23: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22))
|
|
Case 24: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23))
|
|
Case 25: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24))
|
|
Case 26: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25))
|
|
Case 27: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26))
|
|
Case 28: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27))
|
|
Case 29: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28))
|
|
Case 30: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28, a29))
|
|
End Select
|
|
End Function
|