mirror of
https://github.com/kanaka/mal.git
synced 2024-10-04 01:17:33 +03:00
Merge 96cda20bfa
into dcf8f4d7b9
This commit is contained in:
commit
46fb12bf48
14
README.md
14
README.md
@ -134,6 +134,7 @@ FAQ](docs/FAQ.md) where I attempt to answer some common questions.
|
||||
| [VHDL](#vhdl) | [Dov Murik](https://github.com/dubek) |
|
||||
| [Vimscript](#vimscript) | [Dov Murik](https://github.com/dubek) |
|
||||
| [Visual Basic.NET](#visual-basicnet) | [Joel Martin](https://github.com/kanaka) |
|
||||
| [Visual Basic Script](#visual-basic-script) | [Baichao Liu](https://github.com/OldLiu001) |
|
||||
| [WebAssembly](#webassembly-wasm) (wasm) | [Joel Martin](https://github.com/kanaka) |
|
||||
| [Wren](#wren) | [Dov Murik](https://github.com/dubek) |
|
||||
| [XSLT](#xslt) | [Ali MohammadPur](https://github.com/alimpfard) |
|
||||
@ -1218,6 +1219,19 @@ make
|
||||
mono ./stepX_YYY.exe
|
||||
```
|
||||
|
||||
### Visual Basic Script ###
|
||||
|
||||
The VBScript implementation of mal has been tested on Windows 10 1909.
|
||||
`install.vbs` can help you install the requirements (.NET 2.0 3.0 3.5).
|
||||
If you havn't install `.NET 2.0 3.0 3.5`, it will popup a window for installation.
|
||||
If you already installed that, it will do nothing.
|
||||
|
||||
```
|
||||
cd impls\vbs
|
||||
install.vbs
|
||||
cscript -nologo stepX_YYY.vbs
|
||||
```
|
||||
|
||||
### WebAssembly (wasm) ###
|
||||
|
||||
The WebAssembly implementation is written in
|
||||
|
866
impls/vbs/core.vbs
Normal file
866
impls/vbs/core.vbs
Normal file
@ -0,0 +1,866 @@
|
||||
Option Explicit
|
||||
|
||||
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)
|
||||
|
63
impls/vbs/env.vbs
Normal file
63
impls/vbs/env.vbs
Normal file
@ -0,0 +1,63 @@
|
||||
Option Explicit
|
||||
|
||||
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
|
2
impls/vbs/install.vbs
Normal file
2
impls/vbs/install.vbs
Normal file
@ -0,0 +1,2 @@
|
||||
On Error Resume Next
|
||||
CreateObject("System.Collections.ArrayList")
|
93
impls/vbs/printer.vbs
Normal file
93
impls/vbs/printer.vbs
Normal file
@ -0,0 +1,93 @@
|
||||
Option Explicit
|
||||
|
||||
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
|
287
impls/vbs/reader.vbs
Normal file
287
impls/vbs/reader.vbs
Normal file
@ -0,0 +1,287 @@
|
||||
Option Explicit
|
||||
|
||||
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
|
28
impls/vbs/step0_repl.vbs
Normal file
28
impls/vbs/step0_repl.vbs
Normal file
@ -0,0 +1,28 @@
|
||||
Option Explicit
|
||||
|
||||
Function Read(strCode)
|
||||
Read = strCode
|
||||
End Function
|
||||
|
||||
Function Evaluate(strCode)
|
||||
Evaluate = strCode
|
||||
End Function
|
||||
|
||||
Function Print(strCode)
|
||||
Print = strCode
|
||||
End Function
|
||||
|
||||
Function REP(strCode)
|
||||
REP = Print(Evaluate(Read(strCode)))
|
||||
End Function
|
||||
|
||||
Dim strCode
|
||||
While True 'REPL
|
||||
WScript.StdOut.Write "user> "
|
||||
On Error Resume Next
|
||||
strCode = WScript.StdIn.ReadLine()
|
||||
If Err.Number <> 0 Then WScript.Quit 0
|
||||
On Error Goto 0
|
||||
|
||||
WScript.Echo REP(strCode)
|
||||
Wend
|
57
impls/vbs/step1_read_print.vbs
Normal file
57
impls/vbs/step1_read_print.vbs
Normal file
@ -0,0 +1,57 @@
|
||||
Option Explicit
|
||||
|
||||
Include "Types.vbs"
|
||||
Include "Reader.vbs"
|
||||
Include "Printer.vbs"
|
||||
|
||||
Call REPL()
|
||||
|
||||
Sub REPL()
|
||||
Dim strCode
|
||||
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 Err.Number <> 0 Then
|
||||
'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description
|
||||
WScript.StdErr.WriteLine "Exception: " + Err.Description
|
||||
Else
|
||||
If strRes <> "" Then
|
||||
WScript.Echo strRes
|
||||
End If
|
||||
End If
|
||||
On Error Goto 0
|
||||
Wend
|
||||
End Sub
|
||||
|
||||
Function Read(strCode)
|
||||
Set Read = ReadString(strCode)
|
||||
End Function
|
||||
|
||||
Function Evaluate(objCode)
|
||||
Set Evaluate = objCode
|
||||
End Function
|
||||
|
||||
Function Print(objCode)
|
||||
Print = PrintMalType(objCode, True)
|
||||
End Function
|
||||
|
||||
Function REP(strCode)
|
||||
REP = Print(Evaluate(Read(strCode)))
|
||||
End Function
|
||||
|
||||
Sub Include(strFileName)
|
||||
With CreateObject("Scripting.FileSystemObject")
|
||||
ExecuteGlobal .OpenTextFile( _
|
||||
.GetParentFolderName( _
|
||||
.GetFile(WScript.ScriptFullName)) & _
|
||||
"\" & strFileName).ReadAll
|
||||
End With
|
||||
End Sub
|
196
impls/vbs/step2_eval.vbs
Normal file
196
impls/vbs/step2_eval.vbs
Normal file
@ -0,0 +1,196 @@
|
||||
Option Explicit
|
||||
|
||||
Include "Types.vbs"
|
||||
Include "Reader.vbs"
|
||||
Include "Printer.vbs"
|
||||
|
||||
Class Enviroment
|
||||
Private objDict
|
||||
Private objSelf
|
||||
|
||||
Private Sub Class_Initialize
|
||||
Set objDict = CreateObject("Scripting.Dictionary")
|
||||
End Sub
|
||||
|
||||
Public Function Add(objSymbol, objProcedure)
|
||||
objDict.Add objSymbol.Value, objProcedure
|
||||
End Function
|
||||
|
||||
Public Property Set Self(objThis)
|
||||
Set objSelf = objThis
|
||||
End Property
|
||||
|
||||
Public Function Find(varKey)
|
||||
Set Find = objSelf
|
||||
End Function
|
||||
|
||||
Public Function [Get](objSymbol)
|
||||
If objDict.Exists(objSymbol.Value) Then
|
||||
Set [Get] = objDict.Item(objSymbol.Value)
|
||||
Else
|
||||
Err.Raise vbObjectError, _
|
||||
"Enviroment", "Symbol '" + PrintMalType(objSymbol, True) + "' not found."
|
||||
End If
|
||||
End Function
|
||||
End Class
|
||||
|
||||
Dim objEnv
|
||||
Set objEnv = New Enviroment
|
||||
Set objEnv.Self = objEnv
|
||||
|
||||
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
|
||||
objEnv.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
|
||||
objEnv.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
|
||||
objEnv.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
|
||||
objEnv.Add NewMalSym("/"), NewVbsProc("MDiv", False)
|
||||
|
||||
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
|
||||
|
||||
Call REPL()
|
||||
Sub REPL()
|
||||
Dim strCode, strResult
|
||||
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 Err.Number <> 0 Then
|
||||
'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description
|
||||
WScript.StdErr.WriteLine "Exception: " + Err.Description
|
||||
Else
|
||||
If strRes <> "" Then
|
||||
WScript.Echo strRes
|
||||
End If
|
||||
End If
|
||||
On Error Goto 0
|
||||
Wend
|
||||
End Sub
|
||||
|
||||
Function Read(strCode)
|
||||
Set Read = ReadString(strCode)
|
||||
End Function
|
||||
|
||||
Function Evaluate(objCode, objEnv)
|
||||
If TypeName(objCode) = "Nothing" Then
|
||||
Set Evaluate = Nothing
|
||||
Exit Function
|
||||
End If
|
||||
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
|
||||
|
||||
Set Evaluate = varRet
|
||||
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), objEnv))
|
||||
End Function
|
||||
|
||||
Sub Include(strFileName)
|
||||
With CreateObject("Scripting.FileSystemObject")
|
||||
ExecuteGlobal .OpenTextFile( _
|
||||
.GetParentFolderName( _
|
||||
.GetFile(WScript.ScriptFullName)) & _
|
||||
"\" & strFileName).ReadAll
|
||||
End With
|
||||
End Sub
|
207
impls/vbs/step3_env.vbs
Normal file
207
impls/vbs/step3_env.vbs
Normal file
@ -0,0 +1,207 @@
|
||||
Option Explicit
|
||||
|
||||
Include "Types.vbs"
|
||||
Include "Reader.vbs"
|
||||
Include "Printer.vbs"
|
||||
Include "Env.vbs"
|
||||
|
||||
Dim objEnv
|
||||
Set objEnv = 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
|
||||
objEnv.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
|
||||
objEnv.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
|
||||
objEnv.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
|
||||
objEnv.Add NewMalSym("/"), NewVbsProc("MDiv", False)
|
||||
|
||||
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 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
|
||||
objEnv.Add NewMalSym("def!"), NewVbsProc("MDef", True)
|
||||
|
||||
Function MLet(objArgs, objEnv)
|
||||
Dim varRet
|
||||
CheckArgNum objArgs, 2
|
||||
|
||||
Dim objBinds
|
||||
Set objBinds = objArgs.Item(1)
|
||||
If objBinds.Type <> TYPES.LIST And _
|
||||
objBinds.Type <> TYPES.VECTOR Then
|
||||
Err.Raise vbObjectError, _
|
||||
"MLet", "Wrong argument type."
|
||||
End If
|
||||
|
||||
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 = Evaluate(objArgs.Item(2), objNewEnv)
|
||||
Set MLet = varRet
|
||||
End Function
|
||||
objEnv.Add NewMalSym("let*"), NewVbsProc("MLet", True)
|
||||
|
||||
Call REPL()
|
||||
Sub REPL()
|
||||
Dim strCode, strResult
|
||||
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 Err.Number <> 0 Then
|
||||
'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description
|
||||
WScript.StdErr.WriteLine "Exception: " + Err.Description
|
||||
Else
|
||||
If strRes <> "" Then
|
||||
WScript.Echo strRes
|
||||
End If
|
||||
End If
|
||||
On Error Goto 0
|
||||
Wend
|
||||
End Sub
|
||||
|
||||
Function Read(strCode)
|
||||
Set Read = ReadString(strCode)
|
||||
End Function
|
||||
|
||||
Function Evaluate(objCode, objEnv)
|
||||
If TypeName(objCode) = "Nothing" Then
|
||||
Set Evaluate = Nothing
|
||||
Exit Function
|
||||
End If
|
||||
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
|
||||
|
||||
Set Evaluate = varRet
|
||||
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), objEnv))
|
||||
End Function
|
||||
|
||||
Sub Include(strFileName)
|
||||
With CreateObject("Scripting.FileSystemObject")
|
||||
ExecuteGlobal .OpenTextFile( _
|
||||
.GetParentFolderName( _
|
||||
.GetFile(WScript.ScriptFullName)) & _
|
||||
"\" & strFileName).ReadAll
|
||||
End With
|
||||
End Sub
|
221
impls/vbs/step4_if_fn_do.vbs
Normal file
221
impls/vbs/step4_if_fn_do.vbs
Normal file
@ -0,0 +1,221 @@
|
||||
Option Explicit
|
||||
|
||||
Include "Types.vbs"
|
||||
Include "Reader.vbs"
|
||||
Include "Printer.vbs"
|
||||
Include "Env.vbs"
|
||||
Include "Core.vbs"
|
||||
|
||||
Function EvalLater(objMal, objEnv)
|
||||
' A fake implement, for compatibility.
|
||||
Dim varRes
|
||||
Set varRes = Evaluate(objMal, 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 = Evaluate(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 - 1
|
||||
Set varRet = Evaluate(objArgs.Item(i), objEnv)
|
||||
Next
|
||||
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 = Evaluate(objArgs.Item(2), objEnv)
|
||||
Else
|
||||
If objArgs.Count - 1 = 3 Then
|
||||
Set varRet = Evaluate(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)
|
||||
|
||||
Call InitBuiltIn()
|
||||
|
||||
Call REPL()
|
||||
Sub REPL()
|
||||
Dim strCode, strResult
|
||||
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 Err.Number <> 0 Then
|
||||
'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description
|
||||
WScript.StdErr.WriteLine "Exception: " + Err.Description
|
||||
Else
|
||||
If strRes <> "" Then
|
||||
WScript.Echo strRes
|
||||
End If
|
||||
End If
|
||||
On Error Goto 0
|
||||
Wend
|
||||
End Sub
|
||||
|
||||
Function Read(strCode)
|
||||
Set Read = ReadString(strCode)
|
||||
End Function
|
||||
|
||||
Function Evaluate(objCode, objEnv)
|
||||
If TypeName(objCode) = "Nothing" Then
|
||||
Set Evaluate = Nothing
|
||||
Exit Function
|
||||
End If
|
||||
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
|
||||
|
||||
Set Evaluate = varRet
|
||||
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
|
242
impls/vbs/step5_tco.vbs
Normal file
242
impls/vbs/step5_tco.vbs
Normal file
@ -0,0 +1,242 @@
|
||||
Option Explicit
|
||||
|
||||
Include "Types.vbs"
|
||||
Include "Reader.vbs"
|
||||
Include "Printer.vbs"
|
||||
Include "Env.vbs"
|
||||
Include "Core.vbs"
|
||||
|
||||
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)
|
||||
|
||||
Call InitBuiltIn()
|
||||
|
||||
Call REPL()
|
||||
Sub REPL()
|
||||
Dim strCode, strResult
|
||||
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 Err.Number <> 0 Then
|
||||
'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description
|
||||
WScript.StdErr.WriteLine "Exception: " + Err.Description
|
||||
Else
|
||||
If strRes <> "" Then
|
||||
WScript.Echo strRes
|
||||
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
|
||||
|
||||
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
|
270
impls/vbs/step6_file.vbs
Normal file
270
impls/vbs/step6_file.vbs
Normal file
@ -0,0 +1,270 @@
|
||||
Option Explicit
|
||||
|
||||
Include "Types.vbs"
|
||||
Include "Reader.vbs"
|
||||
Include "Printer.vbs"
|
||||
Include "Env.vbs"
|
||||
Include "Core.vbs"
|
||||
|
||||
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)
|
||||
|
||||
Call InitBuiltIn()
|
||||
|
||||
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
|
||||
|
||||
Call REPL()
|
||||
Sub REPL()
|
||||
Dim strCode, strResult
|
||||
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 Err.Number <> 0 Then
|
||||
'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description
|
||||
WScript.StdErr.WriteLine "Exception: " + Err.Description
|
||||
Else
|
||||
If strRes <> "" Then
|
||||
WScript.Echo strRes
|
||||
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
|
||||
|
||||
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
|
394
impls/vbs/step7_quote.vbs
Normal file
394
impls/vbs/step7_quote.vbs
Normal file
@ -0,0 +1,394 @@
|
||||
Option Explicit
|
||||
|
||||
Include "Types.vbs"
|
||||
Include "Reader.vbs"
|
||||
Include "Printer.vbs"
|
||||
Include "Env.vbs"
|
||||
Include "Core.vbs"
|
||||
|
||||
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
|
||||
|
||||
Call InitBuiltIn()
|
||||
|
||||
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
|
||||
|
||||
Call REPL()
|
||||
Sub REPL()
|
||||
Dim strCode, strResult
|
||||
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 Err.Number <> 0 Then
|
||||
'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description
|
||||
WScript.StdErr.WriteLine "Exception: " + Err.Description
|
||||
Else
|
||||
If strRes <> "" Then
|
||||
WScript.Echo strRes
|
||||
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
|
||||
|
||||
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
|
451
impls/vbs/step8_macros.vbs
Normal file
451
impls/vbs/step8_macros.vbs
Normal file
@ -0,0 +1,451 @@
|
||||
Option Explicit
|
||||
|
||||
Include "Types.vbs"
|
||||
Include "Reader.vbs"
|
||||
Include "Printer.vbs"
|
||||
Include "Env.vbs"
|
||||
Include "Core.vbs"
|
||||
|
||||
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)
|
||||
|
||||
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
|
||||
|
||||
Call REPL()
|
||||
Sub REPL()
|
||||
Dim strCode, strResult
|
||||
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 Err.Number <> 0 Then
|
||||
'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description
|
||||
WScript.StdErr.WriteLine "Exception: " + Err.Description
|
||||
Else
|
||||
If strRes <> "" Then
|
||||
WScript.Echo strRes
|
||||
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
|
518
impls/vbs/step9_try.vbs
Normal file
518
impls/vbs/step9_try.vbs
Normal file
@ -0,0 +1,518 @@
|
||||
Option Explicit
|
||||
|
||||
Include "Types.vbs"
|
||||
Include "Reader.vbs"
|
||||
Include "Printer.vbs"
|
||||
Include "Env.vbs"
|
||||
Include "Core.vbs"
|
||||
|
||||
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
|
||||
|
||||
Call REPL()
|
||||
Sub REPL()
|
||||
Dim strCode, strResult
|
||||
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 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
|
||||
Else
|
||||
If strRes <> "" Then
|
||||
WScript.Echo strRes
|
||||
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
|
519
impls/vbs/stepA_mal.vbs
Normal file
519
impls/vbs/stepA_mal.vbs
Normal file
@ -0,0 +1,519 @@
|
||||
Option Explicit
|
||||
|
||||
Include "Types.vbs"
|
||||
Include "Reader.vbs"
|
||||
Include "Printer.vbs"
|
||||
Include "Env.vbs"
|
||||
Include "Core.vbs"
|
||||
|
||||
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
|
||||
|
||||
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 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
|
||||
Else
|
||||
If strRes <> "" Then
|
||||
WScript.Echo strRes
|
||||
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
|
6
impls/vbs/tests/step4_if_fn_do.mal
Normal file
6
impls/vbs/tests/step4_if_fn_do.mal
Normal file
@ -0,0 +1,6 @@
|
||||
((fn* [x] [x]) (list 1 2 3))
|
||||
((fn* [x] [x]) [1 2 3])
|
||||
((fn* [x] (list x)) (list 1 2 3))
|
||||
((fn* [x] (list x)) [1 2 3])
|
||||
((fn* [x] x) (list 1 2 3))
|
||||
((fn* [x] x) [1 2 3])
|
4
impls/vbs/tests/step9_try.mal
Normal file
4
impls/vbs/tests/step9_try.mal
Normal file
@ -0,0 +1,4 @@
|
||||
(throw (list 1 2 3))
|
||||
(try* (throw {}) (catch* e (do (prn e) (throw e))))
|
||||
(try* (throw (list 1 2 3)) (catch* exc (do (prn "err:" exc) 7)))
|
||||
(try* (map throw (list "my err")) (catch* exc exc))
|
612
impls/vbs/types.vbs
Normal file
612
impls/vbs/types.vbs
Normal file
@ -0,0 +1,612 @@
|
||||
Option Explicit
|
||||
|
||||
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
|
Loading…
Reference in New Issue
Block a user