[Visual Basic .NET] 纯文本查看 复制代码
' mal.vbs
' A MAL (Lisp) Language Interpreter witten in VBScript
' Code by OldLiu
' https://github.com/kanaka/mal
' https://github.com/OldLiu001/mal/tree/master/impls/vbs
Option Explicit
CreateObject("System.Collections.ArrayList")
Const strHost = "CSCRIPT.EXE" 'WSCRIPT
If Not UCase(Right(WScript.FullName,11)) = UCase(strHost) Then
Dim Args,Arg
For Each Arg in Wscript.Arguments
Args=Args&Chr(&H20)&Chr(&H22)&Arg&Chr(&H22)
Next
CreateObject("Wscript.Shell").Run _
strHost&Chr(&H20)&Chr(&H22)&WScript.ScriptFullName&Chr(&H22)&Args
WScript.Quit
End If
Dim TYPES
Set TYPES = New MalTypes
Class MalTypes
Public LIST, VECTOR, HASHMAP, [BOOLEAN], NIL
Public KEYWORD, [STRING], NUMBER, SYMBOL
Public PROCEDURE, ATOM
Public [TypeName]
Private Sub Class_Initialize
[TypeName] = Array( _
"LIST", "VECTOR", "HASHMAP", "BOOLEAN", _
"NIL", "KEYWORD", "STRING", "NUMBER", _
"SYMBOL", "PROCEDURE", "ATOM")
Dim i
For i = 0 To UBound([TypeName])
Execute "[" + [TypeName](i) + "] = " + CStr(i)
Next
End Sub
End Class
Class MalType
Public [Type]
Public Value
Private varMeta
Public Property Get MetaData()
If IsEmpty(varMeta) Then
Set MetaData = NewMalNil()
Else
Set MetaData = varMeta
End If
End Property
Public Property Set MetaData(objMeta)
Set varMeta = objMeta
End Property
Public Function Copy()
Set Copy = NewMalType([Type], Value)
End Function
Public Function Init(lngType, varValue)
[Type] = lngType
Value = varValue
End Function
End Class
Function NewMalType(lngType, varValue)
Dim varResult
Set varResult = New MalType
varResult.Init lngType, varValue
Set NewMalType = varResult
End Function
Function NewMalBool(varValue)
Set NewMalBool = NewMalType(TYPES.BOOLEAN, varValue)
End Function
Function NewMalNil()
Set NewMalNil = NewMalType(TYPES.NIL, Empty)
End Function
Function NewMalKwd(varValue)
Set NewMalKwd = NewMalType(TYPES.KEYWORD, varValue)
End Function
Function NewMalStr(varValue)
Set NewMalStr = NewMalType(TYPES.STRING, varValue)
End Function
Function NewMalNum(varValue)
Set NewMalNum = NewMalType(TYPES.NUMBER, varValue)
End Function
Function NewMalSym(varValue)
Set NewMalSym = NewMalType(TYPES.SYMBOL, varValue)
End Function
Class MalAtom
Public [Type]
Public Value
Private varMeta
Public Property Get MetaData()
If IsEmpty(varMeta) Then
Set MetaData = NewMalNil()
Else
Set MetaData = varMeta
End If
End Property
Public Property Set MetaData(objMeta)
Set varMeta = objMeta
End Property
Public Function Copy()
Set Copy = NewMalAtom(Value)
End Function
Public Sub Reset(objMal)
Set Value = objMal
End Sub
Private Sub Class_Initialize
[Type] = TYPES.ATOM
End Sub
End Class
Function NewMalAtom(varValue)
Dim varRes
Set varRes = New MalAtom
varRes.Reset varValue
Set NewMalAtom = varRes
End Function
Class MalList ' Extends MalType
Public [Type]
Public Value
Private varMeta
Public Property Get MetaData()
If IsEmpty(varMeta) Then
Set MetaData = NewMalNil()
Else
Set MetaData = varMeta
End If
End Property
Public Property Set MetaData(objMeta)
Set varMeta = objMeta
End Property
Public Function Copy()
Set Copy = New MalList
Set Copy.Value = Value
End Function
Private Sub Class_Initialize
[Type] = TYPES.LIST
Set Value = CreateObject("System.Collections.ArrayList")
End Sub
Public Function Init(arrValues)
Dim i
For i = 0 To UBound(arrValues)
Add arrValues(i)
Next
End Function
Public Function Add(objMalType)
Value.Add objMalType
End Function
Public Property Get Item(i)
Set Item = Value.Item(i)
End Property
Public Property Let Item(i, varValue)
Value.Item(i) = varValue
End Property
Public Property Set Item(i, varValue)
Set Value.Item(i) = varValue
End Property
Public Function Count()
Count = Value.Count
End Function
End Class
Function NewMalList(arrValues)
Dim varResult
Set varResult = New MalList
varResult.Init arrValues
Set NewMalList = varResult
End Function
Class MalVector ' Extends MalType
Public [Type]
Public Value
Private varMeta
Public Property Get MetaData()
If IsEmpty(varMeta) Then
Set MetaData = NewMalNil()
Else
Set MetaData = varMeta
End If
End Property
Public Property Set MetaData(objMeta)
Set varMeta = objMeta
End Property
Public Function Copy()
Set Copy = New MalVector
Set Copy.Value = Value
End Function
Private Sub Class_Initialize
[Type] = TYPES.VECTOR
Set Value = CreateObject("System.Collections.ArrayList")
End Sub
Public Function Init(arrValues)
Dim i
For i = 0 To UBound(arrValues)
Add arrValues(i)
Next
End Function
Public Function Add(objMalType)
Value.Add objMalType
End Function
Public Property Get Item(i)
Set Item = Value.Item(i)
End Property
Public Property Let Item(i, varValue)
Value.Item(i) = varValue
End Property
Public Property Set Item(i, varValue)
Set Value.Item(i) = varValue
End Property
Public Function Count()
Count = Value.Count
End Function
End Class
Function NewMalVec(arrValues)
Dim varResult
Set varResult = New MalVector
varResult.Init arrValues
Set NewMalVec = varResult
End Function
Class MalHashmap 'Extends MalType
Public [Type]
Public Value
Private varMeta
Public Property Get MetaData()
If IsEmpty(varMeta) Then
Set MetaData = NewMalNil()
Else
Set MetaData = varMeta
End If
End Property
Public Property Set MetaData(objMeta)
Set varMeta = objMeta
End Property
Public Function Copy()
Set Copy = New MalHashmap
Set Copy.Value = Value
End Function
Private Sub Class_Initialize
[Type] = TYPES.HASHMAP
Set Value = CreateObject("Scripting.Dictionary")
End Sub
Public Function Init(arrKeys, arrValues)
Dim i
For i = 0 To UBound(arrKeys)
Add arrKeys(i), arrValues(i)
Next
End Function
Private Function M2S(objKey)
Dim varRes
Select Case objKey.Type
Case TYPES.STRING
varRes = "S" + objKey.Value
Case TYPES.KEYWORD
varRes = "K" + objKey.Value
Case Else
Err.Raise vbObjectError, _
"MalHashmap", "Unexpect key type."
End Select
M2S = varRes
End Function
Private Function S2M(strKey)
Dim varRes
Select Case Left(strKey, 1)
Case "S"
Set varRes = NewMalStr(Right(strKey, Len(strKey) - 1))
Case "K"
Set varRes = NewMalKwd(Right(strKey, Len(strKey) - 1))
Case Else
Err.Raise vbObjectError, _
"MalHashmap", "Unexpect key type."
End Select
Set S2M = varRes
End Function
Public Function Add(varKey, varValue)
If varKey.Type <> TYPES.STRING And _
varKey.Type <> TYPES.KEYWORD Then
Err.Raise vbObjectError, _
"MalHashmap", "Unexpect key type."
End If
Set Value.Item(M2S(varKey)) = varValue
'Value.Add M2S(varKey), varValue
End Function
Public Property Get Keys()
Dim aKeys
aKeys = Value.Keys
Dim aRes()
ReDim aRes(UBound(aKeys))
Dim i
For i = 0 To UBound(aRes)
Set aRes(i) = S2M(aKeys(i))
Next
Keys = aRes
End Property
Public Function Count()
Count = Value.Count
End Function
Public Property Get Item(i)
Set Item = Value.Item(M2S(i))
End Property
Public Function Exists(varKey)
If varKey.Type <> TYPES.STRING And _
varKey.Type <> TYPES.KEYWORD Then
Err.Raise vbObjectError, _
"MalHashmap", "Unexpect key type."
End If
Exists = Value.Exists(M2S(varKey))
End Function
Public Property Let Item(i, varValue)
Value.Item(M2S(i)) = varValue
End Property
Public Property Set Item(i, varValue)
Set Value.Item(M2S(i)) = varValue
End Property
End Class
Function NewMalMap(arrKeys, arrValues)
Dim varResult
Set varResult = New MalHashmap
varResult.Init arrKeys, arrValues
Set NewMalMap = varResult
End Function
Class VbsProcedure 'Extends MalType
Public [Type]
Public Value
Public IsMacro
Public boolSpec
Public MetaData
Private Sub Class_Initialize
[Type] = TYPES.PROCEDURE
IsMacro = False
Set MetaData = NewMalNil()
End Sub
Public Property Get IsSpecial()
IsSpecial = boolSpec
End Property
Public Function Init(objFunction, boolIsSpec)
Set Value = objFunction
boolSpec = boolIsSpec
End Function
Public Function Apply(objArgs, objEnv)
Dim varResult
If boolSpec Then
Set varResult = Value(objArgs, objEnv)
Else
Set varResult = Value(EvaluateRest(objArgs, objEnv), objEnv)
End If
Set Apply = varResult
End Function
Public Function ApplyWithoutEval(objArgs, objEnv)
Dim varResult
Set varResult = Value(objArgs, objEnv)
Set ApplyWithoutEval = varResult
End Function
Public Function Copy()
Dim varRes
Set varRes = New VbsProcedure
varRes.Type = [Type]
Set varRes.Value = Value
varRes.IsMacro = IsMacro
varRes.boolSpec = boolSpec
Set Copy = varRes
End Function
End Class
Function NewVbsProc(strFnName, boolSpec)
Dim varResult
Set varResult = New VbsProcedure
varResult.Init GetRef(strFnName), boolSpec
Set NewVbsProc = varResult
End Function
Class MalProcedure 'Extends MalType
Public [Type]
Public Value
Public IsMacro
Public Property Get IsSpecial()
IsSpecial = False
End Property
Public MetaData
Private Sub Class_Initialize
[Type] = TYPES.PROCEDURE
IsMacro = False
Set MetaData = NewMalNil()
End Sub
Public objParams, objCode, objSavedEnv
Public Function Init(objP, objC, objE)
Set objParams = objP
Set objCode = objC
Set objSavedEnv = objE
End Function
Public Function Apply(objArgs, objEnv)
If IsMacro Then
Err.Raise vbObjectError, _
"MalProcedureApply", "Not a procedure."
End If
Dim varRet
Dim objNewEnv
Set objNewEnv = NewEnv(objSavedEnv)
Dim i
i = 0
Dim objList
While i < objParams.Count
If objParams.Item(i).Value = "&" Then
If objParams.Count - 1 = i + 1 Then
Set objList = NewMalList(Array())
objNewEnv.Add objParams.Item(i + 1), objList
While i + 1 < objArgs.Count
objList.Add Evaluate(objArgs.Item(i + 1), objEnv)
i = i + 1
Wend
i = objParams.Count ' Break While
Else
Err.Raise vbObjectError, _
"MalProcedureApply", "Invalid parameter(s)."
End If
Else
If i + 1 >= objArgs.Count Then
Err.Raise vbObjectError, _
"MalProcedureApply", "Need more arguments."
End If
objNewEnv.Add objParams.Item(i), _
Evaluate(objArgs.Item(i + 1), objEnv)
i = i + 1
End If
Wend
Set varRet = EvalLater(objCode, objNewEnv)
Set Apply = varRet
End Function
Public Function MacroApply(objArgs, objEnv)
If Not IsMacro Then
Err.Raise vbObjectError, _
"MalMacroApply", "Not a macro."
End If
Dim varRet
Dim objNewEnv
Set objNewEnv = NewEnv(objSavedEnv)
Dim i
i = 0
Dim objList
While i < objParams.Count
If objParams.Item(i).Value = "&" Then
If objParams.Count - 1 = i + 1 Then
Set objList = NewMalList(Array())
' No evaluation
objNewEnv.Add objParams.Item(i + 1), objList
While i + 1 < objArgs.Count
objList.Add objArgs.Item(i + 1)
i = i + 1
Wend
i = objParams.Count ' Break While
Else
Err.Raise vbObjectError, _
"MalMacroApply", "Invalid parameter(s)."
End If
Else
If i + 1 >= objArgs.Count Then
Err.Raise vbObjectError, _
"MalMacroApply", "Need more arguments."
End If
' No evaluation
objNewEnv.Add objParams.Item(i), _
objArgs.Item(i + 1)
i = i + 1
End If
Wend
' EvalLater -> Evaluate
Set varRet = Evaluate(objCode, objNewEnv)
Set MacroApply = varRet
End Function
Public Function ApplyWithoutEval(objArgs, objEnv)
Dim varRet
Dim objNewEnv
Set objNewEnv = NewEnv(objSavedEnv)
Dim i
i = 0
Dim objList
While i < objParams.Count
If objParams.Item(i).Value = "&" Then
If objParams.Count - 1 = i + 1 Then
Set objList = NewMalList(Array())
' No evaluation
objNewEnv.Add objParams.Item(i + 1), objList
While i + 1 < objArgs.Count
objList.Add objArgs.Item(i + 1)
i = i + 1
Wend
i = objParams.Count ' Break While
Else
Err.Raise vbObjectError, _
"MalMacroApply", "Invalid parameter(s)."
End If
Else
If i + 1 >= objArgs.Count Then
Err.Raise vbObjectError, _
"MalMacroApply", "Need more arguments."
End If
' No evaluation
objNewEnv.Add objParams.Item(i), _
objArgs.Item(i + 1)
i = i + 1
End If
Wend
' EvalLater -> Evaluate
Set varRet = Evaluate(objCode, objNewEnv)
Set ApplyWithoutEval = varRet
End Function
Public Function Copy()
Dim varRes
Set varRes = New MalProcedure
varRes.Type = [Type]
varRes.Value = Value
varRes.IsMacro = IsMacro
Set varRes.objParams = objParams
Set varRes.objCode = objCode
Set varRes.objSavedEnv = objSavedEnv
Set Copy = varRes
End Function
End Class
Function NewMalProc(objParams, objCode, objEnv)
Dim varRet
Set varRet = New MalProcedure
varRet.Init objParams, objCode, objEnv
Set NewMalProc = varRet
End Function
Function NewMalMacro(objParams, objCode, objEnv)
Dim varRet
Set varRet = New MalProcedure
varRet.Init objParams, objCode, objEnv
varRet.IsMacro = True
Set NewMalProc = varRet
End Function
Function SetMeta(objMal, objMeta)
Dim varRes
Set varRes = objMal.Copy
Set varRes.MetaData = objMeta
Set SetMeta = varRes
End Function
Function GetMeta(objMal)
Set GetMeta = objMal.MetaData
End Function
Function ReadString(strCode)
Dim objTokens
Set objTokens = Tokenize(strCode)
Set ReadString = ReadForm(objTokens)
If Not objTokens.AtEnd() Then
Err.Raise vbObjectError, _
"ReadForm", "extra token '" + objTokens.Current() + "'."
End If
End Function
Class Tokens
Private objQueue
Private objRE
Private Sub Class_Initialize
Set objRE = New RegExp
With objRE
.Pattern = "[\s,]*" + _
"(" + _
"~@" + "|" + _
"[\[\]{}()'`~^@]" + "|" + _
"""(?:\\.|[^\\""])*""?" + "|" + _
";.*" + "|" + _
"[^\s\[\]{}('""`,;)]*" + _
")"
.IgnoreCase = True
.Global = True
End With
Set objQueue = CreateObject("System.Collections.Queue")
End Sub
Public Function Init(strCode)
Dim objMatches, objMatch
Set objMatches = objRE.Execute(strCode)
Dim strToken
For Each objMatch In objMatches
strToken = Trim(objMatch.SubMatches(0))
If Not (Left(strToken, 1) = ";" Or strToken = "") Then
objQueue.Enqueue strToken
End If
Next
End Function
Public Function Current()
Current = objQueue.Peek()
End Function
Public Function MoveToNext()
MoveToNext = objQueue.Dequeue()
End Function
Public Function AtEnd()
AtEnd = (objQueue.Count = 0)
End Function
Public Function Count()
Count = objQueue.Count
End Function
End Class
Function Tokenize(strCode) ' Return objTokens
Dim varResult
Set varResult = New Tokens
varResult.Init strCode
Set Tokenize = varResult
End Function
Function ReadForm(objTokens) ' Return Nothing / MalType
If objTokens.AtEnd() Then
Set ReadForm = Nothing
Exit Function
End If
Dim strToken
strToken = objTokens.Current()
Dim varResult
If InStr("([{", strToken) Then
Select Case strToken
Case "("
Set varResult = ReadList(objTokens)
Case "["
Set varResult = ReadVector(objTokens)
Case "{"
Set varResult = ReadHashmap(objTokens)
End Select
ElseIf InStr("'`~@", strToken) Then
Set varResult = ReadSpecial(objTokens)
ElseIf InStr(")]}", strToken) Then
Err.Raise vbObjectError, _
"ReadForm", "unbalanced parentheses."
ElseIf strToken = "^" Then
Set varResult = ReadMetadata(objTokens)
Else
Set varResult = ReadAtom(objTokens)
End If
Set ReadForm = varResult
End Function
Function ReadMetadata(objTokens)
Dim varResult
Call objTokens.MoveToNext()
Dim objTemp
Set objTemp = ReadForm(objTokens)
Set varResult = NewMalList(Array( _
NewMalSym("with-meta"), _
ReadForm(objTokens), objTemp))
Set ReadMetadata = varResult
End Function
Function ReadSpecial(objTokens)
Dim varResult
Dim strToken, strAlias
strToken = objTokens.Current()
Select Case strToken
Case "'"
strAlias = "quote"
Case "`"
strAlias = "quasiquote"
Case "~"
strAlias = "unquote"
Case "~@"
strAlias = "splice-unquote"
Case "@"
strAlias = "deref"
Case Else
Err.Raise vbObjectError, _
"ReadSpecial", "unknown token '" & strAlias & "'."
End Select
Call objTokens.MoveToNext()
Set varResult = NewMalList(Array( _
NewMalSym(strAlias), _
ReadForm(objTokens)))
Set ReadSpecial = varResult
End Function
Function ReadList(objTokens)
Dim varResult
Call objTokens.MoveToNext()
If objTokens.AtEnd() Then
Err.Raise vbObjectError, _
"ReadList", "unbalanced parentheses."
End If
Set varResult = NewMalList(Array())
With varResult
While objTokens.Count() > 1 And objTokens.Current() <> ")"
.Add ReadForm(objTokens)
Wend
End With
If objTokens.MoveToNext() <> ")" Then
Err.Raise vbObjectError, _
"ReadList", "unbalanced parentheses."
End If
Set ReadList = varResult
End Function
Function ReadVector(objTokens)
Dim varResult
Call objTokens.MoveToNext()
If objTokens.AtEnd() Then
Err.Raise vbObjectError, _
"ReadVector", "unbalanced parentheses."
End If
Set varResult = NewMalVec(Array())
With varResult
While objTokens.Count() > 1 And objTokens.Current() <> "]"
.Add ReadForm(objTokens)
Wend
End With
If objTokens.MoveToNext() <> "]" Then
Err.Raise vbObjectError, _
"ReadVector", "unbalanced parentheses."
End If
Set ReadVector = varResult
End Function
Function ReadHashmap(objTokens)
Dim varResult
Call objTokens.MoveToNext()
If objTokens.Count = 0 Then
Err.Raise vbObjectError, _
"ReadHashmap", "unbalanced parentheses."
End If
Set varResult = NewMalMap(Array(), Array())
Dim objKey, objValue
With varResult
While objTokens.Count > 2 And objTokens.Current() <> "}"
Set objKey = ReadForm(objTokens)
Set objValue = ReadForm(objTokens)
.Add objKey, objValue
Wend
End With
If objTokens.MoveToNext() <> "}" Then
Err.Raise vbObjectError, _
"ReadHashmap", "unbalanced parentheses."
End If
Set ReadHashmap = varResult
End Function
Function ReadAtom(objTokens)
Dim varResult
Dim strAtom
strAtom = objTokens.MoveToNext()
Select Case strAtom
Case "true"
Set varResult = NewMalBool(True)
Case "false"
Set varResult = NewMalBool(False)
Case "nil"
Set varResult = NewMalNil()
Case Else
Select Case Left(strAtom, 1)
Case ":"
Set varResult = NewMalKwd(strAtom)
Case """"
Set varResult = NewMalStr(ParseString(strAtom))
Case Else
If IsNumeric(strAtom) Then
Set varResult = NewMalNum(Eval(strAtom))
Else
Set varResult = NewMalSym(strAtom)
End If
End Select
End Select
Set ReadAtom = varResult
End Function
Function ParseString(strRaw)
If Right(strRaw, 1) <> """" Or Len(strRaw) < 2 Then
Err.Raise vbObjectError, _
"ParseString", "unterminated string, got EOF."
End If
Dim strTemp
strTemp = Mid(strRaw, 2, Len(strRaw) - 2)
Dim i
i = 1
ParseString = ""
While i <= Len(strTemp) - 1
Select Case Mid(strTemp, i, 2)
Case "\\"
ParseString = ParseString & "\"
Case "\n"
ParseString = ParseString & vbCrLf
Case "\"""
ParseString = ParseString & """"
Case Else
ParseString = ParseString & Mid(strTemp, i, 1)
i = i - 1
End Select
i = i + 2
Wend
If i <= Len(strTemp) Then
' Last char is not processed.
If Right(strTemp, 1) <> "\" Then
ParseString = ParseString & Right(strTemp, 1)
Else
Err.Raise vbObjectError, _
"ParseString", "unterminated string, got EOF."
End If
End If
End Function
Function PrintMalType(objMal, boolReadable)
Dim varResult
varResult = ""
If TypeName(objMal) = "Nothing" Then
PrintMalType = ""
Exit Function
End If
Dim i
Select Case objMal.Type
Case TYPES.LIST
With objMal
For i = 0 To .Count - 2
varResult = varResult & _
PrintMalType(.Item(i), boolReadable) & " "
Next
If .Count > 0 Then
varResult = varResult & _
PrintMalType(.Item(.Count - 1), boolReadable)
End If
End With
varResult = "(" & varResult & ")"
Case TYPES.VECTOR
With objMal
For i = 0 To .Count - 2
varResult = varResult & _
PrintMalType(.Item(i), boolReadable) & " "
Next
If .Count > 0 Then
varResult = varResult & _
PrintMalType(.Item(.Count - 1), boolReadable)
End If
End With
varResult = "[" & varResult & "]"
Case TYPES.HASHMAP
With objMal
Dim arrKeys
arrKeys = .Keys
For i = 0 To .Count - 2
varResult = varResult & _
PrintMalType(arrKeys(i), boolReadable) & " " & _
PrintMalType(.Item(arrKeys(i)), boolReadable) & " "
Next
If .Count > 0 Then
varResult = varResult & _
PrintMalType(arrKeys(.Count - 1), boolReadable) & " " & _
PrintMalType(.Item(arrKeys(.Count - 1)), boolReadable)
End If
End With
varResult = "{" & varResult & "}"
Case TYPES.STRING
If boolReadable Then
varResult = EscapeString(objMal.Value)
Else
varResult = objMal.Value
End If
Case TYPES.BOOLEAN
If objMal.Value Then
varResult = "true"
Else
varResult = "false"
End If
Case TYPES.NIL
varResult = "nil"
Case TYPES.NUMBER
varResult = CStr(objMal.Value)
Case TYPES.PROCEDURE
varResult = "#<function>"
Case TYPES.KEYWORD
varResult = objMal.Value
Case TYPES.SYMBOL
varResult = objMal.Value
Case TYPES.ATOM
varResult = "(atom " + PrintMalType(objMal.Value, boolReadable) + ")"
Case Else
Err.Raise vbObjectError, _
"PrintMalType", "Unknown type."
End Select
PrintMalType = varResult
End Function
Function EscapeString(strRaw)
EscapeString = strRaw
EscapeString = Replace(EscapeString, "\", "\\")
EscapeString = Replace(EscapeString, vbCrLf, "\n")
EscapeString = Replace(EscapeString, """", "\""")
EscapeString = """" & EscapeString & """"
End Function
Function NewEnv(objOuter)
Dim varRet
Set varRet = New Environment
Set varRet.Self = varRet
Set varRet.Outer = objOuter
Set NewEnv = varRet
End Function
Class Environment
Private objOuter, objSelf
Private objBinds
Private Sub Class_Initialize()
Set objBinds = CreateObject("Scripting.Dictionary")
Set objOuter = Nothing
Set objSelf = Nothing
End Sub
Public Property Set Outer(objEnv)
Set objOuter = objEnv
End Property
Public Property Get Outer()
Set Outer = objOuter
End Property
Public Property Set Self(objEnv)
Set objSelf = objEnv
End Property
Public Sub Add(varKey, varValue)
Set objBinds.Item(varKey.Value) = varValue
End Sub
Public Function Find(varKey)
Dim varRet
If objBinds.Exists(varKey.Value) Then
Set varRet = objSelf
Else
If TypeName(objOuter) <> "Nothing" Then
Set varRet = objOuter.Find(varKey)
Else
Err.Raise vbObjectError, _
"Environment", "'" + varKey.Value + "' not found"
End If
End If
Set Find = varRet
End Function
Public Function [Get](varKey)
Dim objEnv, varRet
Set objEnv = Find(varKey)
If objEnv Is objSelf Then
Set varRet = objBinds(varKey.Value)
Else
Set varRet = objEnv.Get(varKey)
End If
Set [Get] = varRet
End Function
End Class
Sub CheckArgNum(objArgs, lngArgNum)
If objArgs.Count - 1 <> lngArgNum Then
Err.Raise vbObjectError, _
"CheckArgNum", "Wrong number of arguments."
End IF
End Sub
Sub CheckType(objMal, varType)
If objMal.Type <> varType Then
Err.Raise vbObjectError, _
"CheckType", "Wrong argument type."
End IF
End Sub
Function IsListOrVec(objMal)
IsListOrVec = _
objMal.Type = TYPES.LIST Or _
objMal.Type = TYPES.VECTOR
End Function
Sub CheckListOrVec(objMal)
If Not IsListOrVec(objMal) Then
Err.Raise vbObjectError, _
"CheckListOrVec", _
"Wrong argument type, need a list or a vector."
End If
End Sub
Dim objNS
Set objNS = NewEnv(Nothing)
Function MAdd(objArgs, objEnv)
CheckArgNum objArgs, 2
CheckType objArgs.Item(1), TYPES.NUMBER
CheckType objArgs.Item(2), TYPES.NUMBER
Set MAdd = NewMalNum( _
objArgs.Item(1).Value + objArgs.Item(2).Value)
End Function
objNS.Add NewMalSym("+"), NewVbsProc("MAdd", False)
Function MSub(objArgs, objEnv)
CheckArgNum objArgs, 2
CheckType objArgs.Item(1), TYPES.NUMBER
CheckType objArgs.Item(2), TYPES.NUMBER
Set MSub = NewMalNum( _
objArgs.Item(1).Value - objArgs.Item(2).Value)
End Function
objNS.Add NewMalSym("-"), NewVbsProc("MSub", False)
Function MMul(objArgs, objEnv)
CheckArgNum objArgs, 2
CheckType objArgs.Item(1), TYPES.NUMBER
CheckType objArgs.Item(2), TYPES.NUMBER
Set MMul = NewMalNum( _
objArgs.Item(1).Value * objArgs.Item(2).Value)
End Function
objNS.Add NewMalSym("*"), NewVbsProc("MMul", False)
Function MDiv(objArgs, objEnv)
CheckArgNum objArgs, 2
CheckType objArgs.Item(1), TYPES.NUMBER
CheckType objArgs.Item(2), TYPES.NUMBER
Set MDiv = NewMalNum( _
objArgs.Item(1).Value \ objArgs.Item(2).Value)
End Function
objNS.Add NewMalSym("/"), NewVbsProc("MDiv", False)
Function MList(objArgs, objEnv)
Dim varRet
Set varRet = NewMalList(Array())
Dim i
For i = 1 To objArgs.Count - 1
varRet.Add objArgs.Item(i)
Next
Set MList = varRet
End Function
objNS.Add NewMalSym("list"), NewVbsProc("MList", False)
Function MIsList(objArgs, objEnv)
CheckArgNum objArgs, 1
Set MIsList = NewMalBool(objArgs.Item(1).Type = TYPES.LIST)
End Function
objNS.Add NewMalSym("list?"), NewVbsProc("MIsList", False)
Function MIsEmpty(objArgs, objEnv)
CheckArgNum objArgs, 1
CheckListOrVec objArgs.Item(1)
Set MIsEmpty = NewMalBool(objArgs.Item(1).Count = 0)
End Function
objNS.Add NewMalSym("empty?"), NewVbsProc("MIsEmpty", False)
Function MCount(objArgs, objEnv)
CheckArgNum objArgs, 1
If objArgs.Item(1).Type = TYPES.NIL Then
Set MCount = NewMalNum(0)
Else
CheckListOrVec objArgs.Item(1)
Set MCount = NewMalNum(objArgs.Item(1).Count)
End If
End Function
objNS.Add NewMalSym("count"), NewVbsProc("MCount", False)
Function MEqual(objArgs, objEnv)
Dim varRet
CheckArgNum objArgs, 2
Dim boolResult, i
If IsListOrVec(objArgs.Item(1)) And _
IsListOrVec(objArgs.Item(2)) Then
If objArgs.Item(1).Count <> objArgs.Item(2).Count Then
Set varRet = NewMalBool(False)
Else
boolResult = True
For i = 0 To objArgs.Item(1).Count - 1
boolResult = boolResult And _
MEqual(NewMalList(Array(Nothing, _
objArgs.Item(1).Item(i), _
objArgs.Item(2).Item(i))), objEnv).Value
Next
Set varRet = NewMalBool(boolResult)
End If
Else
If objArgs.Item(1).Type <> objArgs.Item(2).Type Then
Set varRet = NewMalBool(False)
Else
Select Case objArgs.Item(1).Type
Case TYPES.HASHMAP
'Err.Raise vbObjectError, _
' "MEqual", "Not implement yet~"
If UBound(objArgs.Item(1).Keys) <> UBound(objArgs.Item(2).Keys) Then
Set varRet = NewMalBool(False)
Set MEqual = varRet
Exit Function
End If
boolResult = True
For Each i In objArgs.Item(1).Keys
If Not objArgs.Item(2).Exists(i) Then
Set varRet = NewMalBool(False)
Set MEqual = varRet
Exit Function
End If
boolResult = boolResult And _
MEqual(NewMalList(Array(Nothing, objArgs.Item(1).Item(i), objArgs.Item(2).Item(i))), objEnv).Value
Next
Set varRet = NewMalBool(boolResult)
Case Else
Set varRet = NewMalBool( _
objArgs.Item(1).Value = objArgs.Item(2).Value)
End Select
End If
End If
Set MEqual = varRet
End Function
objNS.Add NewMalSym("="), NewVbsProc("MEqual", False)
Function MGreater(objArgs, objEnv)
Dim varRet
CheckArgNum objArgs, 2
CheckType objArgs.Item(1), TYPES.NUMBER
CheckType objArgs.Item(2), TYPES.NUMBER
Set varRet = NewMalBool( _
objArgs.Item(1).Value > objArgs.Item(2).Value)
Set MGreater = varRet
End Function
objNS.Add NewMalSym(">"), NewVbsProc("MGreater", False)
Function MPrStr(objArgs, objEnv)
Dim varRet
Dim strRet
strRet = ""
Dim i
If objArgs.Count - 1 >= 1 Then
strRet = PrintMalType(objArgs.Item(1), True)
End If
For i = 2 To objArgs.Count - 1
strRet = strRet + " " + _
PrintMalType(objArgs.Item(i), True)
Next
Set varRet = NewMalStr(strRet)
Set MPrStr = varRet
End Function
objNS.Add NewMalSym("pr-str"), NewVbsProc("MPrStr", False)
Function MStr(objArgs, objEnv)
Dim varRet
Dim strRet
strRet = ""
Dim i
For i = 1 To objArgs.Count - 1
strRet = strRet + _
PrintMalType(objArgs.Item(i), False)
Next
Set varRet = NewMalStr(strRet)
Set MStr = varRet
End Function
objNS.Add NewMalSym("str"), NewVbsProc("MStr", False)
Function MPrn(objArgs, objEnv)
Dim varRet
Dim objStr
Set objStr = MPrStr(objArgs, objEnv)
WScript.StdOut.WriteLine objStr.Value
Set varRet = NewMalNil()
Set MPrn = varRet
End Function
objNS.Add NewMalSym("prn"), NewVbsProc("MPrn", False)
Function MPrintln(objArgs, objEnv)
Dim varRet
Dim strRes
strRes = ""
Dim i
If objArgs.Count - 1 >= 1 Then
strRes = PrintMalType(objArgs.Item(1), False)
End If
For i = 2 To objArgs.Count - 1
strRes = strRes + " " + _
PrintMalType(objArgs.Item(i), False)
Next
WScript.StdOut.WriteLine strRes
Set varRet = NewMalNil()
Set MPrintln = varRet
End Function
objNS.Add NewMalSym("println"), NewVbsProc("MPrintln", False)
Sub InitBuiltIn()
REP "(def! not (fn* [bool] (if bool false true)))"
REP "(def! <= (fn* [a b] (not (> a b))))"
REP "(def! < (fn* [a b] (> b a)))"
REP "(def! >= (fn* [a b] (not (> b a))))"
REP "(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"
REP "(def! cons (fn* [a b] (concat (list a) b)))"
REP "(def! nil? (fn* [x] (= x nil)))"
REP "(def! true? (fn* [x] (= x true)))"
REP "(def! false? (fn* [x] (= x false)))"
REP "(def! vector (fn* [& args] (vec args)))"
REP "(def! vals (fn* [hmap] (map (fn* [key] (get hmap key)) (keys hmap))))"
REP "(def! *host-language* ""VBScript"")"
End Sub
Function MReadStr(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
CheckType objArgs.Item(1), TYPES.STRING
Set varRes = ReadString(objArgs.Item(1).Value)
If TypeName(varRes) = "Nothing" Then
Set varRes = NewMalNil()
End If
Set MReadStr = varRes
End Function
objNS.Add NewMalSym("read-string"), NewVbsProc("MReadStr", False)
Function MSlurp(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
CheckType objArgs.Item(1), TYPES.STRING
Dim strRes
With CreateObject("Scripting.FileSystemObject")
strRes = .OpenTextFile( _
.GetParentFolderName( _
.GetFile(WScript.ScriptFullName)) & _
"\" & objArgs.Item(1).Value).ReadAll
End With
Set varRes = NewMalStr(strRes)
Set MSlurp = varRes
End Function
objNS.Add NewMalSym("slurp"), NewVbsProc("MSlurp", False)
Function MAtom(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
Set varRes = NewMalAtom(objArgs.Item(1))
Set MAtom = varRes
End Function
objNS.Add NewMalSym("atom"), NewVbsProc("MAtom", False)
Function MIsAtom(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.ATOM)
Set MIsAtom = varRes
End Function
objNS.Add NewMalSym("atom?"), NewVbsProc("MIsAtom", False)
Function MDeref(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
CheckType objArgs.Item(1), TYPES.ATOM
Set varRes = objArgs.Item(1).Value
Set MDeref = varRes
End Function
objNS.Add NewMalSym("deref"), NewVbsProc("MDeref", False)
Function MReset(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 2
CheckType objArgs.Item(1), TYPES.ATOM
objArgs.Item(1).Reset objArgs.Item(2)
Set varRes = objArgs.Item(2)
Set MReset = varRes
End Function
objNS.Add NewMalSym("reset!"), NewVbsProc("MReset", False)
Function MSwap(objArgs, objEnv)
Dim varRes
If objArgs.Count - 1 < 2 Then
Err.Raise vbObjectError, _
"MSwap", "Need more arguments."
End If
Dim objAtom, objFn
Set objAtom = objArgs.Item(1)
CheckType objAtom, TYPES.ATOM
Set objFn = objArgs.Item(2)
CheckType objFn, TYPES.PROCEDURE
Dim objProg
Set objProg = NewMalList(Array(objFn))
objProg.Add objAtom.Value
Dim i
For i = 3 To objArgs.Count - 1
objProg.Add objArgs.Item(i)
Next
objAtom.Reset objFn.ApplyWithoutEval(objProg, objEnv)
Set varRes = objAtom.Value
Set MSwap = varRes
End Function
objNS.Add NewMalSym("swap!"), NewVbsProc("MSwap", False)
Function MConcat(objArgs, objEnv)
Dim varRes
Dim i, j
Set varRes = NewMalList(Array())
For i = 1 To objArgs.Count - 1
If Not IsListOrVec(objArgs.Item(i)) Then
Err.Raise vbObjectError, _
"MConcat", "Invaild argument(s)."
End If
For j = 0 To objArgs.Item(i).Count - 1
varRes.Add objArgs.Item(i).Item(j)
Next
Next
Set MConcat = varRes
End Function
objNS.Add NewMalSym("concat"), NewVbsProc("MConcat", False)
Function MVec(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
CheckListOrVec objArgs.Item(1)
Set varRes = NewMalVec(Array())
Dim i
For i = 0 To objArgs.Item(1).Count - 1
varRes.Add objArgs.Item(1).Item(i)
Next
Set MVec = varRes
End Function
objNS.Add NewMalSym("vec"), NewVbsProc("MVec", False)
Function MNth(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 2
CheckListOrVec objArgs.Item(1)
CheckType objArgs.Item(2), TYPES.NUMBER
If objArgs.Item(2).Value < objArgs.Item(1).Count Then
Set varRes = objArgs.Item(1).Item(objArgs.Item(2).Value)
Else
Err.Raise vbObjectError, _
"MNth", "Index out of bounds."
End If
Set MNth = varRes
End Function
objNS.Add NewMalSym("nth"), NewVbsProc("MNth", False)
Function MFirst(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
If objArgs.Item(1).Type = TYPES.NIL Then
Set varRes = NewMalNil()
Set MFirst = varRes
Exit Function
End If
CheckListOrVec objArgs.Item(1)
If objArgs.Item(1).Count < 1 Then
Set varRes = NewMalNil()
Else
Set varRes = objArgs.Item(1).Item(0)
End If
Set MFirst = varRes
End Function
objNS.Add NewMalSym("first"), NewVbsProc("MFirst", False)
Function MRest(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
If objArgs.Item(1).Type = TYPES.NIL Then
Set varRes = NewMalList(Array())
Set MRest = varRes
Exit Function
End If
Dim objList
Set objList = objArgs.Item(1)
CheckListOrVec objList
Set varRes = NewMalList(Array())
Dim i
For i = 1 To objList.Count - 1
varRes.Add objList.Item(i)
Next
Set MRest = varRes
End Function
objNS.Add NewMalSym("rest"), NewVbsProc("MRest", False)
Sub InitMacro()
REP "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ""odd number of forms to cond"")) (cons'cond (rest (rest xs)))))))"
'REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
REP "(def! *gensym-counter* (atom 0))"
REP "(def! gensym (fn* [] (symbol (str ""G__"" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))"
REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))"
End Sub
Class MalException
Private objDict
Private Sub Class_Initialize
Set objDict = CreateObject("Scripting.Dictionary")
End Sub
Public Sub Add(varKey, varValue)
objDict.Add varKey, varValue
End Sub
Public Function Item(varKey)
Set Item = objDict.Item(varKey)
End Function
Public Sub Remove(varKey)
objDict.Remove varKey
End Sub
End Class
Dim objExceptions
Set objExceptions = New MalException
Function MThrow(objArgs, objEnv)
CheckArgNum objArgs, 1
Dim strRnd
strRnd = CStr(Rnd())
objExceptions.Add strRnd, objArgs.Item(1)
Err.Raise vbObjectError, _
"MThrow", strRnd
End Function
objNS.Add NewMalSym("throw"), NewVbsProc("MThrow", False)
Function MApply(objArgs, objEnv)
Dim varRes
If objArgs.Count - 1 < 2 Then
Err.Raise vbObjectError, _
"MApply", "Need more arguments."
End If
Dim objFn
Set objFn = objArgs.Item(1)
CheckType objFn, TYPES.PROCEDURE
If objFn.IsSpecial Or objFn.IsMacro Then
Err.Raise vbObjectError, _
"MApply", "Need a function."
End If
Dim objAST
Set objAST = NewMalList(Array(objFn))
Dim i
For i = 2 To objArgs.Count - 2
objAST.Add objArgs.Item(i)
Next
Dim objSeq
Set objSeq = objArgs.Item(objArgs.Count - 1)
CheckListOrVec objSeq
For i = 0 To objSeq.Count - 1
objAST.Add objSeq.Item(i)
Next
Set varRes = objFn.ApplyWithoutEval(objAST, objEnv)
Set MApply = varRes
End Function
objNS.Add NewMalSym("apply"), NewVbsProc("MApply", False)
Function MMap(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 2
Dim objFn, objSeq
Set objFn = objArgs.Item(1)
Set objSeq = objArgs.Item(2)
CheckType objFn, TYPES.PROCEDURE
CheckListOrVec objSeq
If objFn.IsSpecial Or objFn.IsMacro Then
Err.Raise vbObjectError, _
"MApply", "Need a function."
End If
Set varRes = NewMalList(Array())
Dim i
For i = 0 To objSeq.Count - 1
varRes.Add objFn.ApplyWithoutEval(NewMalList(Array( _
objFn, objSeq.Item(i))), objEnv)
Next
Set MMap = varRes
End Function
objNS.Add NewMalSym("map"), NewVbsProc("MMap", False)
Function MIsSymbol(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.SYMBOL)
Set MIsSymbol = varRes
End Function
objNS.Add NewMalSym("symbol?"), NewVbsProc("MIsSymbol", False)
Function MSymbol(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
CheckType objArgs.Item(1), TYPES.STRING
Set varRes = NewMalSym(objArgs.Item(1).Value)
Set MSymbol = varRes
End Function
objNS.Add NewMalSym("symbol"), NewVbsProc("MSymbol", False)
Function MKeyword(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
Select Case objArgs.Item(1).Type
Case TYPES.STRING
Set varRes = NewMalKwd(":" + objArgs.Item(1).Value)
Case TYPES.KEYWORD
Set varRes = objArgs.Item(1)
Case Else
Err.Raise vbObjectError, _
"MKeyword", "Unexpect argument(s)."
End Select
Set MKeyword = varRes
End Function
objNS.Add NewMalSym("keyword"), NewVbsProc("MKeyword", False)
Function MIsKeyword(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.KEYWORD)
Set MIsKeyword = varRes
End Function
objNS.Add NewMalSym("keyword?"), NewVbsProc("MIsKeyword", False)
Function MIsSeq(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
Set varRes = NewMalBool( _
objArgs.Item(1).Type = TYPES.LIST Or _
objArgs.Item(1).Type = TYPES.VECTOR)
Set MIsSeq = varRes
End Function
objNS.Add NewMalSym("sequential?"), NewVbsProc("MIsSeq", False)
Function MIsVec(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.VECTOR)
Set MIsVec = varRes
End Function
objNS.Add NewMalSym("vector?"), NewVbsProc("MIsVec", False)
Function MIsMap(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.HASHMAP)
Set MIsMap = varRes
End Function
objNS.Add NewMalSym("map?"), NewVbsProc("MIsMap", False)
Function MHashMap(objArgs, objEnv)
Dim varRes
If objArgs.Count Mod 2 <> 1 Then
Err.Raise vbObjectError, _
"MHashMap", "Unexpect argument(s)."
End If
Set varRes = NewMalMap(Array(), Array())
Dim i
For i = 1 To objArgs.Count - 1 Step 2
varRes.Add objArgs.Item(i), objArgs.Item(i + 1)
Next
Set MHashMap = varRes
End Function
objNS.Add NewMalSym("hash-map"), NewVbsProc("MHashMap", False)
Function MAssoc(objArgs, objEnv)
Dim varRes
If objArgs.Count - 1 < 3 Or objArgs.Count Mod 2 <> 0 Then
Err.Raise vbObjectError, _
"MHashMap", "Unexpect argument(s)."
End If
Dim objMap
Set objMap = objArgs.Item(1)
CheckType objMap, TYPES.HASHMAP
Dim i
Set varRes = NewMalMap(Array(), Array())
For Each i In objMap.Keys
varRes.Add i, objMap.Item(i)
Next
For i = 2 To objArgs.Count - 1 Step 2
varRes.Add objArgs.Item(i), objArgs.Item(i + 1)
Next
Set MAssoc = varRes
End Function
objNS.Add NewMalSym("assoc"), NewVbsProc("MAssoc", False)
Function MGet(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 2
If objArgs.Item(1).Type = TYPES.NIL Then
Set varRes = NewMalNil()
Else
CheckType objArgs.Item(1), TYPES.HASHMAP
If objArgs.Item(1).Exists(objArgs.Item(2)) Then
Set varRes = objArgs.Item(1).Item(objArgs.Item(2))
Else
Set varRes = NewMalNil()
End If
End If
Set MGet = varRes
End Function
objNS.Add NewMalSym("get"), NewVbsProc("MGet", False)
Function MDissoc(objArgs, objEnv)
Dim varRes
'CheckArgNum objArgs, 2
CheckType objArgs.Item(1), TYPES.HASHMAP
If objArgs.Item(1).Exists(objArgs.Item(2)) Then
Set varRes = NewMalMap(Array(), Array())
Dim i
Dim j, boolFlag
For Each i In objArgs.Item(1).Keys
boolFlag = True
For j = 2 To objArgs.Count - 1
If i.Type = objArgs.Item(j).Type And _
i.Value = objArgs.Item(j).Value Then
boolFlag = False
End If
Next
If boolFlag Then
varRes.Add i, objArgs.Item(1).Item(i)
End If
Next
Else
Set varRes = objArgs.Item(1)
End If
Set MDissoc = varRes
End Function
objNS.Add NewMalSym("dissoc"), NewVbsProc("MDissoc", False)
Function MKeys(objArgs, objEnv)
CheckArgNum objArgs, 1
CheckType objArgs.Item(1), TYPES.HASHMAP
Set MKeys = NewMalList(objArgs.Item(1).Keys)
End Function
objNS.Add NewMalSym("keys"), NewVbsProc("MKeys", False)
Function MIsContains(objArgs, objEnv)
CheckArgNum objArgs, 2
CheckType objArgs.Item(1), TYPES.HASHMAP
Set MIsContains = NewMalBool(objArgs.Item(1).Exists(objArgs.Item(2)))
End Function
objNS.Add NewMalSym("contains?"), NewVbsProc("MIsContains", False)
Function MReadLine(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
CheckType objArgs.Item(1), TYPES.STRING
Dim strInput
WScript.StdOut.Write objArgs.Item(1).Value
On Error Resume Next
strInput = WScript.StdIn.ReadLine()
If Err.Number <> 0 Then
Set varRes = NewMalNil()
Else
Set varRes = NewMalStr(strInput)
End If
On Error Goto 0
Set MReadLine = varRes
End Function
objNS.Add NewMalSym("readline"), NewVbsProc("MReadLine", False)
Function MTimeMs(objArgs, objEnv)
Set MTimeMs = NewMalNum(CLng(Timer * 1000))
End Function
objNS.Add NewMalSym("time-ms"), NewVbsProc("MTimeMs", False)
Function MIsStr(objArgs, objEnv)
CheckArgNum objArgs, 1
Set MIsStr = NewMalBool(objArgs.Item(1).Type = TYPES.STRING)
End Function
objNS.Add NewMalSym("string?"), NewVbsProc("MIsStr", False)
Function MIsNum(objArgs, objEnv)
CheckArgNum objArgs, 1
Set MIsNum = NewMalBool(objArgs.Item(1).Type = TYPES.NUMBER)
End Function
objNS.Add NewMalSym("number?"), NewVbsProc("MIsNum", False)
Function MIsFn(objArgs, objEnv)
CheckArgNum objArgs, 1
Dim varRes
varRes = objArgs.Item(1).Type = TYPES.PROCEDURE
If varRes Then
varRes = (Not objArgs.Item(1).IsMacro) And _
(Not objArgs.Item(1).IsSpecial)
End If
Set MIsFn = NewMalBool(varRes)
End Function
objNS.Add NewMalSym("fn?"), NewVbsProc("MIsFn", False)
Function MIsMacro(objArgs, objEnv)
CheckArgNum objArgs, 1
Dim varRes
varRes = objArgs.Item(1).Type = TYPES.PROCEDURE
If varRes Then
varRes = objArgs.Item(1).IsMacro And _
(Not objArgs.Item(1).IsSpecial)
End If
Set MIsMacro = NewMalBool(varRes)
End Function
objNS.Add NewMalSym("macro?"), NewVbsProc("MIsMacro", False)
Function MMeta(objArgs, objEnv)
CheckArgNum objArgs, 1
'CheckType objArgs.Item(1), TYPES.PROCEDURE
Dim varRes
Set varRes = GetMeta(objArgs.Item(1))
Set MMeta = varRes
End Function
objNS.Add NewMalSym("meta"), NewVbsProc("MMeta", False)
Function MWithMeta(objArgs, objEnv)
CheckArgNum objArgs, 2
'CheckType objArgs.Item(1), TYPES.PROCEDURE
Dim varRes
Set varRes = SetMeta(objArgs.Item(1), objArgs.Item(2))
Set MWithMeta = varRes
End Function
objNS.Add NewMalSym("with-meta"), NewVbsProc("MWithMeta", False)
Function MConj(objArgs, objEnv)
If objArgs.Count - 1 < 1 Then
Err.Raise vbObjectError, _
"MConj", "Need more arguments."
End If
Dim varRes
Dim objSeq
Set objSeq = objArgs.Item(1)
Dim i
Select Case objSeq.Type
Case TYPES.LIST
Set varRes = NewMalList(Array())
For i = objArgs.Count - 1 To 2 Step -1
varRes.Add objArgs.Item(i)
Next
For i = 0 To objSeq.Count - 1
varRes.Add objSeq.Item(i)
Next
Case TYPES.VECTOR
Set varRes = NewMalVec(Array())
For i = 0 To objSeq.Count - 1
varRes.Add objSeq.Item(i)
Next
For i = 2 To objArgs.Count - 1
varRes.Add objArgs.Item(i)
Next
Case Else
Err.Raise vbObjectError, _
"MConj", "Unexpect argument type."
End Select
Set MConj = varRes
End Function
objNS.Add NewMalSym("conj"), NewVbsProc("MConj", False)
Function MSeq(objArgs, objEnv)
CheckArgNum objArgs, 1
Dim objSeq
Set objSeq = objArgs.Item(1)
Dim varRes
Dim i
Select Case objSeq.Type
Case TYPES.STRING
If objSeq.Value = "" Then
Set varRes = NewMalNil()
Else
Set varRes = NewMalList(Array())
For i = 1 To Len(objSeq.Value)
varRes.Add NewMalStr(Mid(objSeq.Value, i, 1))
Next
End If
Case TYPES.LIST
If objSeq.Count = 0 Then
Set varRes = NewMalNil()
Else
Set varRes = objSeq
End If
Case TYPES.VECTOR
If objSeq.Count = 0 Then
Set varRes = NewMalNil()
Else
Set varRes = NewMalList(Array())
For i = 0 To objSeq.Count - 1
varRes.Add objSeq.Item(i)
Next
End If
Case TYPES.NIL
Set varRes = NewMalNil()
Case Else
Err.Raise vbObjectError, _
"MSeq", "Unexpect argument type."
End Select
Set MSeq = varRes
End Function
objNS.Add NewMalSym("seq"), NewVbsProc("MSeq", False)
Class TailCall
Public objMalType
Public objEnv
End Class
Function EvalLater(objMal, objEnv)
Dim varRes
Set varRes = New TailCall
Set varRes.objMalType = objMal
Set varRes.objEnv = objEnv
Set EvalLater = varRes
End Function
Function MDef(objArgs, objEnv)
Dim varRet
CheckArgNum objArgs, 2
CheckType objArgs.Item(1), TYPES.SYMBOL
Set varRet = Evaluate(objArgs.Item(2), objEnv)
objEnv.Add objArgs.Item(1), varRet
Set MDef = varRet
End Function
objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True)
Function MLet(objArgs, objEnv)
Dim varRet
CheckArgNum objArgs, 2
Dim objBinds
Set objBinds = objArgs.Item(1)
CheckListOrVec objBinds
If objBinds.Count Mod 2 <> 0 Then
Err.Raise vbObjectError, _
"MLet", "Wrong argument count."
End If
Dim objNewEnv
Set objNewEnv = NewEnv(objEnv)
Dim i, objSym
For i = 0 To objBinds.Count - 1 Step 2
Set objSym = objBinds.Item(i)
CheckType objSym, TYPES.SYMBOL
objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv)
Next
Set varRet = EvalLater(objArgs.Item(2), objNewEnv)
Set MLet = varRet
End Function
objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True)
Function MDo(objArgs, objEnv)
Dim varRet, i
If objArgs.Count - 1 < 1 Then
Err.Raise vbObjectError, _
"MDo", "Need more arguments."
End If
For i = 1 To objArgs.Count - 2
Call Evaluate(objArgs.Item(i), objEnv)
Next
Set varRet = EvalLater( _
objArgs.Item(objArgs.Count - 1), _
objEnv)
Set MDo = varRet
End Function
objNS.Add NewMalSym("do"), NewVbsProc("MDo", True)
Function MIf(objArgs, objEnv)
Dim varRet
If objArgs.Count - 1 <> 3 And _
objArgs.Count - 1 <> 2 Then
Err.Raise vbObjectError, _
"MIf", "Wrong number of arguments."
End If
Dim objCond
Set objCond = Evaluate(objArgs.Item(1), objEnv)
Dim boolCond
If objCond.Type = TYPES.BOOLEAN Then
boolCond = objCond.Value
Else
boolCond = True
End If
boolCond = (boolCond And objCond.Type <> TYPES.NIL)
If boolCond Then
Set varRet = EvalLater(objArgs.Item(2), objEnv)
Else
If objArgs.Count - 1 = 3 Then
Set varRet = EvalLater(objArgs.Item(3), objEnv)
Else
Set varRet = NewMalNil()
End If
End If
Set MIf = varRet
End Function
objNS.Add NewMalSym("if"), NewVbsProc("MIf", True)
Function MFn(objArgs, objEnv)
Dim varRet
CheckArgNum objArgs, 2
Dim objParams, objCode
Set objParams = objArgs.Item(1)
CheckListOrVec objParams
Set objCode = objArgs.Item(2)
Dim i
For i = 0 To objParams.Count - 1
CheckType objParams.Item(i), TYPES.SYMBOL
Next
Set varRet = NewMalProc(objParams, objCode, objEnv)
Set MFn = varRet
End Function
objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True)
Function MEval(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
Set varRes = Evaluate(objArgs.Item(1), objEnv)
Set varRes = EvalLater(varRes, objNS)
Set MEval = varRes
End Function
objNS.Add NewMalSym("eval"), NewVbsProc("MEval", True)
Function MQuote(objArgs, objEnv)
CheckArgNum objArgs, 1
Set MQuote = objArgs.Item(1)
End Function
objNS.Add NewMalSym("quote"), NewVbsProc("MQuote", True)
Function MQuasiQuote(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
Set varRes = EvalLater( _
MQuasiQuoteExpand(objArgs, objEnv), objEnv)
Set MQuasiQuote = varRes
End Function
objNS.Add NewMalSym("quasiquote"), NewVbsProc("MQuasiQuote", True)
Function MQuasiQuoteExpand(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
Set varRes = ExpandHelper(objArgs.Item(1))
If varRes.Splice Then
Err.Raise vbObjectError, _
"MQuasiQuoteExpand", "Wrong return value type."
End If
Set varRes = varRes.Value
Set MQuasiQuoteExpand = varRes
End Function
objNS.Add NewMalSym("quasiquoteexpand"), NewVbsProc("MQuasiQuoteExpand", True)
Class ExpandType
Public Splice
Public Value
End Class
Function NewExpandType(objValue, boolSplice)
Dim varRes
Set varRes = New ExpandType
Set varRes.Value = objValue
varRes.Splice = boolSplice
Set NewExpandType = varRes
End Function
Function ExpandHelper(objArg)
Dim varRes, boolSplice
Dim varBuilder, varEType, i
boolSplice = False
Select Case objArg.Type
Case TYPES.LIST
Dim boolNormal
boolNormal = False
' Check for unquotes.
Select Case objArg.Count
Case 2
' Maybe have a bug here
' like (unquote a b c) should be throw a error
If objArg.Item(0).Type = TYPES.SYMBOL Then
Select Case objArg.Item(0).Value
Case "unquote"
Set varRes = objArg.Item(1)
Case "splice-unquote"
Set varRes = objArg.Item(1)
boolSplice = True
Case Else
boolNormal = True
End Select
Else
boolNormal = True
End If
Case Else
boolNormal = True
End Select
If boolNormal Then
Set varRes = NewMalList(Array())
Set varBuilder = varRes
For i = 0 To objArg.Count - 1
Set varEType = ExpandHelper(objArg.Item(i))
If varEType.Splice Then
varBuilder.Add NewMalSym("concat")
Else
varBuilder.Add NewMalSym("cons")
End If
varBuilder.Add varEType.Value
varBuilder.Add NewMalList(Array())
Set varBuilder = varBuilder.Item(2)
Next
End If
Case TYPES.VECTOR
Set varRes = NewMalList(Array( _
NewMalSym("vec"), NewMalList(Array())))
Set varBuilder = varRes.Item(1)
For i = 0 To objArg.Count - 1
Set varEType = ExpandHelper(objArg.Item(i))
If varEType.Splice Then
varBuilder.Add NewMalSym("concat")
Else
varBuilder.Add NewMalSym("cons")
End If
varBuilder.Add varEType.Value
varBuilder.Add NewMalList(Array())
Set varBuilder = varBuilder.Item(2)
Next
Case TYPES.HASHMAP
' Maybe have a bug here.
' e.g. {"key" ~value}
Set varRes = NewMalList(Array( _
NewMalSym("quote"), objArg))
Case TYPES.SYMBOL
Set varRes = NewMalList(Array( _
NewMalSym("quote"), objArg))
Case Else
' Maybe have a bug here.
' All unspecified type will return itself.
Set varRes = objArg
End Select
Set ExpandHelper = NewExpandType(varRes, boolSplice)
End Function
Function MDefMacro(objArgs, objEnv)
Dim varRet
CheckArgNum objArgs, 2
CheckType objArgs.Item(1), TYPES.SYMBOL
Set varRet = Evaluate(objArgs.Item(2), objEnv).Copy()
CheckType varRet, TYPES.PROCEDURE
varRet.IsMacro = True
objEnv.Add objArgs.Item(1), varRet
Set MDefMacro = varRet
End Function
objNS.Add NewMalSym("defmacro!"), NewVbsProc("MDefMacro", True)
Function IsMacroCall(objCode, objEnv)
Dim varRes
varRes = False
' VBS has no short-circuit evaluation.
If objCode.Type = TYPES.LIST Then
If objCode.Count > 0 Then
If objCode.Item(0).Type = TYPES.SYMBOL Then
Dim varValue
Set varValue = objEnv.Get(objCode.Item(0))
If varValue.Type = TYPES.PROCEDURE Then
If varValue.IsMacro Then
varRes = True
End If
End If
End If
End If
End If
IsMacroCall = varRes
End Function
Function MacroExpand(ByVal objAST, ByVal objEnv)
Dim varRes
While IsMacroCall(objAST, objEnv)
Dim varMacro
Set varMacro = objEnv.Get(objAST.Item(0))
Set objAST = varMacro.MacroApply(objAST, objEnv)
Wend
Set varRes = objAST
Set MacroExpand = varRes
End Function
Function MMacroExpand(objArgs, objEnv)
Dim varRes
CheckArgNum objArgs, 1
Set varRes = MacroExpand(objArgs.Item(1), objEnv)
Set MMacroExpand = varRes
End Function
objNS.Add NewMalSym("macroexpand"), NewVbsProc("MMacroExpand", True)
Function MTry(objArgs, objEnv)
Dim varRes
If objArgs.Count - 1 < 1 Then
Err.Raise vbObjectError, _
"MTry", "Need more arguments."
End If
If objArgs.Count - 1 = 1 Then
Set varRes = EvalLater(objArgs.Item(1), objEnv)
Set MTry = varRes
Exit Function
End If
CheckArgNum objArgs, 2
CheckType objArgs.Item(2), TYPES.LIST
Dim objTry, objCatch
Set objTry = objArgs.Item(1)
Set objCatch = objArgs.Item(2)
CheckArgNum objCatch, 2
CheckType objCatch.Item(0), TYPES.SYMBOL
CheckType objCatch.Item(1), TYPES.SYMBOL
If objCatch.Item(0).Value <> "catch*" Then
Err.Raise vbObjectError, _
"MTry", "Unexpect argument(s)."
End If
On Error Resume Next
Set varRes = Evaluate(objTry, objEnv)
If Err.Number <> 0 Then
Dim objException
If Err.Source <> "MThrow" Then
Set objException = NewMalStr(Err.Description)
Else
Set objException = objExceptions.Item(Err.Description)
objExceptions.Remove Err.Description
End If
Call Err.Clear()
On Error Goto 0
' The code below may cause error too.
' So we should clear err info & throw out any errors.
' Use 'quote' to avoid eval objExp again.
Set varRes = Evaluate(NewMalList(Array( _
NewMalSym("let*"), NewMalList(Array( _
objCatch.Item(1), NewMalList(Array( _
NewMalSym("quote"), objException)))), _
objCatch.Item(2))), objEnv)
Else
On Error Goto 0
End If
Set MTry = varRes
End Function
objNS.Add NewMalSym("try*"), NewVbsProc("MTry", True)
Call InitBuiltIn()
Call InitMacro()
Call InitArgs()
Sub InitArgs()
Dim objArgs
Set objArgs = NewMalList(Array())
Dim i
For i = 1 To WScript.Arguments.Count - 1
objArgs.Add NewMalStr(WScript.Arguments.Item(i))
Next
objNS.Add NewMalSym("*ARGV*"), objArgs
If WScript.Arguments.Count > 0 Then
REP "(load-file """ + WScript.Arguments.Item(0) + """)"
WScript.Quit 0
End If
End Sub
Randomize 1228
Call REPL()
Sub REPL()
Dim strCode, strResult
REP "(println (str ""Mal [""*host-language*""]""))"
While True
WScript.StdOut.Write "user> "
On Error Resume Next
strCode = WScript.StdIn.ReadLine()
If Err.Number <> 0 Then WScript.Quit 0
On Error Goto 0
Dim strRes
On Error Resume Next
strRes = REP(strCode)
If strRes <> "" Then
WScript.Echo strRes
End If
If Err.Number <> 0 Then
If Err.Source = "MThrow" Then
'WScript.StdErr.WriteLine Err.Source + ": " + _
WScript.StdErr.WriteLine "Exception: " + _
PrintMalType(objExceptions.Item(Err.Description), True)
objExceptions.Remove Err.Description
Else
'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description
WScript.StdErr.WriteLine "Exception: " + Err.Description
End If
End If
On Error Goto 0
Wend
End Sub
Function Read(strCode)
Set Read = ReadString(strCode)
End Function
Function Evaluate(ByVal objCode, ByVal objEnv)
While True
If TypeName(objCode) = "Nothing" Then
Set Evaluate = Nothing
Exit Function
End If
Set objCode = MacroExpand(objCode, objEnv)
Dim varRet, objFirst
If objCode.Type = TYPES.LIST Then
If objCode.Count = 0 Then ' ()
Set Evaluate = objCode
Exit Function
End If
Set objFirst = Evaluate(objCode.Item(0), objEnv)
Set varRet = objFirst.Apply(objCode, objEnv)
Else
Set varRet = EvaluateAST(objCode, objEnv)
End If
If TypeName(varRet) = "TailCall" Then
' NOTICE: If not specify 'ByVal',
' Change of arguments will influence
' the caller's variable!
Set objCode = varRet.objMalType
Set objEnv = varRet.objEnv
Else
Set Evaluate = varRet
Exit Function
End If
Wend
End Function
Function EvaluateAST(objCode, objEnv)
Dim varRet, i
Select Case objCode.Type
Case TYPES.SYMBOL
Set varRet = objEnv.Get(objCode)
Case TYPES.LIST
Err.Raise vbObjectError, _
"EvaluateAST", "Unexpect type."
Case TYPES.VECTOR
Set varRet = NewMalVec(Array())
For i = 0 To objCode.Count() - 1
varRet.Add Evaluate(objCode.Item(i), objEnv)
Next
Case TYPES.HASHMAP
Set varRet = NewMalMap(Array(), Array())
For Each i In objCode.Keys()
varRet.Add i, Evaluate(objCode.Item(i), objEnv)
Next
Case Else
Set varRet = objCode
End Select
Set EvaluateAST = varRet
End Function
Function EvaluateRest(objCode, objEnv)
Dim varRet, i
Select Case objCode.Type
Case TYPES.LIST
Set varRet = NewMalList(Array(NewMalNil()))
For i = 1 To objCode.Count() - 1
varRet.Add Evaluate(objCode.Item(i), objEnv)
Next
Case Else
Err.Raise vbObjectError, _
"EvaluateRest", "Unexpected type."
End Select
Set EvaluateRest = varRet
End Function
Function Print(objCode)
Print = PrintMalType(objCode, True)
End Function
Function REP(strCode)
REP = Print(Evaluate(Read(strCode), objNS))
End Function
Sub Include(strFileName)
With CreateObject("Scripting.FileSystemObject")
ExecuteGlobal .OpenTextFile( _
.GetParentFolderName( _
.GetFile(WScript.ScriptFullName)) & _
"\" & strFileName).ReadAll
End With
End Sub
[复制链接]
发表于 2023-1-30 12:30
