From 53c23e3bab183546e1722a56aca05e77be05fd63 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Tue, 22 Oct 2024 16:19:09 +0200 Subject: [PATCH] vbs: merge {macro,quasiquote}expand into EVAL, add DEBUG-EVAL Eval_ast was already reserved to lists. env.vbs: rewrite env.get with a string argument and without exception because this is convenient for DEBUG-EVAL. types.vbs: after a macro expansion, evaluate with TCO. --- impls/vbs/env.vbs | 23 +++--------- impls/vbs/step3_env.vbs | 26 ++++++++++++- impls/vbs/step4_if_fn_do.vbs | 26 ++++++++++++- impls/vbs/step5_tco.vbs | 25 +++++++++++- impls/vbs/step6_file.vbs | 25 +++++++++++- impls/vbs/step7_quote.vbs | 26 ++++++++++++- impls/vbs/step8_macros.vbs | 73 ++++++++++++++---------------------- impls/vbs/step9_try.vbs | 73 ++++++++++++++---------------------- impls/vbs/stepA_mal.vbs | 73 ++++++++++++++---------------------- impls/vbs/types.vbs | 2 +- 10 files changed, 212 insertions(+), 160 deletions(-) diff --git a/impls/vbs/env.vbs b/impls/vbs/env.vbs index c86671b478..2df14d67df 100644 --- a/impls/vbs/env.vbs +++ b/impls/vbs/env.vbs @@ -33,31 +33,18 @@ Class Environment Set objBinds.Item(varKey.Value) = varValue End Sub - Public Function Find(varKey) + Public Function [Get](varKeyStr) Dim varRet - If objBinds.Exists(varKey.Value) Then - Set varRet = objSelf + If objBinds.Exists(varKeyStr) Then + Set varRet = objBinds(varKeyStr) Else If TypeName(objOuter) <> "Nothing" Then - Set varRet = objOuter.Find(varKey) + Set varRet = objOuter.Get(varKeyStr) Else - Err.Raise vbObjectError, _ - "Environment", "'" + varKey.Value + "' not found" + Set varRet = Nothing 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 \ No newline at end of file diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs index fbedef0cd2..daaa9d8eef 100644 --- a/impls/vbs/step3_env.vbs +++ b/impls/vbs/step3_env.vbs @@ -129,11 +129,31 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function +Sub DebugEval(objCode, objEnv) + Dim value, bool + Set value = objEnv.Get("DEBUG-EVAL") + If TypeName(value) = "Nothing" Then + Set bool = False + Else + If value.Type = TYPES.BOOLEAN Then + Set bool = value.Value + Else + Set bool = value.Type <> TYPES.NIL + End If + End If + If bool Then + IO.WriteLine "EVAL: " + PrintMalType(objCode, True) + End If +End Sub + Function Evaluate(objCode, objEnv) If TypeName(objCode) = "Nothing" Then Set Evaluate = Nothing Exit Function End If + + DebugEval objCode, objEnv + Dim varRet, objFirst If objCode.Type = TYPES.LIST Then If objCode.Count = 0 Then ' () @@ -154,7 +174,11 @@ Function EvaluateAST(objCode, objEnv) Dim varRet, i Select Case objCode.Type Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) + Set varRet = objEnv.Get(objCode.Value) + if TypeName(varRet) = "Nothing" Then + Err.Raise vbObjectError, _ + "Environment", "'" + objCode.Value + "' not found" + End If Case TYPES.LIST Err.Raise vbObjectError, _ "EvaluateAST", "Unexpect type." diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs index 38fe48ac5f..aa0c5b5ecd 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -143,11 +143,31 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function +Sub DebugEval(objCode, objEnv) + Dim value, bool + Set value = objEnv.Get("DEBUG-EVAL") + If TypeName(value) = "Nothing" Then + Set bool = False + Else + If value.Type = TYPES.BOOLEAN Then + Set bool = value.Value + Else + Set bool = value.Type <> TYPES.NIL + End If + End If + If bool Then + IO.WriteLine "EVAL: " + PrintMalType(objCode, True) + End If +End Sub + Function Evaluate(objCode, objEnv) If TypeName(objCode) = "Nothing" Then Set Evaluate = Nothing Exit Function End If + + DebugEval objCode, objEnv + Dim varRet, objFirst If objCode.Type = TYPES.LIST Then If objCode.Count = 0 Then ' () @@ -168,7 +188,11 @@ Function EvaluateAST(objCode, objEnv) Dim varRet, i Select Case objCode.Type Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) + Set varRet = objEnv.Get(objCode.Value) + if TypeName(varRet) = "Nothing" Then + Err.Raise vbObjectError, _ + "Environment", "'" + objCode.Value + "' not found" + End If Case TYPES.LIST Err.Raise vbObjectError, _ "EvaluateAST", "Unexpect type." diff --git a/impls/vbs/step5_tco.vbs b/impls/vbs/step5_tco.vbs index c2ea4e4a67..ee01c07d5d 100644 --- a/impls/vbs/step5_tco.vbs +++ b/impls/vbs/step5_tco.vbs @@ -152,6 +152,23 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function +Sub DebugEval(objCode, objEnv) + Dim value, bool + Set value = objEnv.Get("DEBUG-EVAL") + If TypeName(value) = "Nothing" Then + Set bool = False + Else + If value.Type = TYPES.BOOLEAN Then + Set bool = value.Value + Else + Set bool = value.Type <> TYPES.NIL + End If + End If + If bool Then + IO.WriteLine "EVAL: " + PrintMalType(objCode, True) + End If +End Sub + Function Evaluate(ByVal objCode, ByVal objEnv) While True If TypeName(objCode) = "Nothing" Then @@ -159,6 +176,8 @@ Function Evaluate(ByVal objCode, ByVal objEnv) Exit Function End If + DebugEval objCode, objEnv + Dim varRet, objFirst If objCode.Type = TYPES.LIST Then If objCode.Count = 0 Then ' () @@ -189,7 +208,11 @@ Function EvaluateAST(objCode, objEnv) Dim varRet, i Select Case objCode.Type Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) + Set varRet = objEnv.Get(objCode.Value) + if TypeName(varRet) = "Nothing" Then + Err.Raise vbObjectError, _ + "Environment", "'" + objCode.Value + "' not found" + End If Case TYPES.LIST Err.Raise vbObjectError, _ "EvaluateAST", "Unexpect type." diff --git a/impls/vbs/step6_file.vbs b/impls/vbs/step6_file.vbs index e29ff303ca..737fab51ed 100644 --- a/impls/vbs/step6_file.vbs +++ b/impls/vbs/step6_file.vbs @@ -180,6 +180,23 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function +Sub DebugEval(objCode, objEnv) + Dim value, bool + Set value = objEnv.Get("DEBUG-EVAL") + If TypeName(value) = "Nothing" Then + Set bool = False + Else + If value.Type = TYPES.BOOLEAN Then + Set bool = value.Value + Else + Set bool = value.Type <> TYPES.NIL + End If + End If + If bool Then + IO.WriteLine "EVAL: " + PrintMalType(objCode, True) + End If +End Sub + Function Evaluate(ByVal objCode, ByVal objEnv) While True If TypeName(objCode) = "Nothing" Then @@ -187,6 +204,8 @@ Function Evaluate(ByVal objCode, ByVal objEnv) Exit Function End If + DebugEval objCode, objEnv + Dim varRet, objFirst If objCode.Type = TYPES.LIST Then If objCode.Count = 0 Then ' () @@ -217,7 +236,11 @@ Function EvaluateAST(objCode, objEnv) Dim varRet, i Select Case objCode.Type Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) + Set varRet = objEnv.Get(objCode.Value) + if TypeName(varRet) = "Nothing" Then + Err.Raise vbObjectError, _ + "Environment", "'" + objCode.Value + "' not found" + End If Case TYPES.LIST Err.Raise vbObjectError, _ "EvaluateAST", "Unexpect type." diff --git a/impls/vbs/step7_quote.vbs b/impls/vbs/step7_quote.vbs index 9d2dce7e40..51fe327da1 100644 --- a/impls/vbs/step7_quote.vbs +++ b/impls/vbs/step7_quote.vbs @@ -160,7 +160,6 @@ Function MQuasiQuoteExpand(objArgs, objEnv) Set MQuasiQuoteExpand = varRes End Function -objNS.Add NewMalSym("quasiquoteexpand"), NewVbsProc("MQuasiQuoteExpand", True) Class ExpandType Public Splice @@ -304,6 +303,23 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function +Sub DebugEval(objCode, objEnv) + Dim value, bool + Set value = objEnv.Get("DEBUG-EVAL") + If TypeName(value) = "Nothing" Then + Set bool = False + Else + If value.Type = TYPES.BOOLEAN Then + Set bool = value.Value + Else + Set bool = value.Type <> TYPES.NIL + End If + End If + If bool Then + IO.WriteLine "EVAL: " + PrintMalType(objCode, True) + End If +End Sub + Function Evaluate(ByVal objCode, ByVal objEnv) While True If TypeName(objCode) = "Nothing" Then @@ -311,6 +327,8 @@ Function Evaluate(ByVal objCode, ByVal objEnv) Exit Function End If + DebugEval objCode, objEnv + Dim varRet, objFirst If objCode.Type = TYPES.LIST Then If objCode.Count = 0 Then ' () @@ -341,7 +359,11 @@ Function EvaluateAST(objCode, objEnv) Dim varRet, i Select Case objCode.Type Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) + Set varRet = objEnv.Get(objCode.Value) + if TypeName(varRet) = "Nothing" Then + Err.Raise vbObjectError, _ + "Environment", "'" + objCode.Value + "' not found" + End If Case TYPES.LIST Err.Raise vbObjectError, _ "EvaluateAST", "Unexpect type." diff --git a/impls/vbs/step8_macros.vbs b/impls/vbs/step8_macros.vbs index 2c05523c1a..68e738012c 100644 --- a/impls/vbs/step8_macros.vbs +++ b/impls/vbs/step8_macros.vbs @@ -160,7 +160,6 @@ Function MQuasiQuoteExpand(objArgs, objEnv) Set MQuasiQuoteExpand = varRes End Function -objNS.Add NewMalSym("quasiquoteexpand"), NewVbsProc("MQuasiQuoteExpand", True) Class ExpandType Public Splice @@ -267,47 +266,6 @@ Function MDefMacro(objArgs, objEnv) 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() @@ -358,6 +316,23 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function +Sub DebugEval(objCode, objEnv) + Dim value, bool + Set value = objEnv.Get("DEBUG-EVAL") + If TypeName(value) = "Nothing" Then + Set bool = False + Else + If value.Type = TYPES.BOOLEAN Then + Set bool = value.Value + Else + Set bool = value.Type <> TYPES.NIL + End If + End If + If bool Then + IO.WriteLine "EVAL: " + PrintMalType(objCode, True) + End If +End Sub + Function Evaluate(ByVal objCode, ByVal objEnv) While True If TypeName(objCode) = "Nothing" Then @@ -365,7 +340,7 @@ Function Evaluate(ByVal objCode, ByVal objEnv) Exit Function End If - Set objCode = MacroExpand(objCode, objEnv) + DebugEval objCode, objEnv Dim varRet, objFirst If objCode.Type = TYPES.LIST Then @@ -375,7 +350,11 @@ Function Evaluate(ByVal objCode, ByVal objEnv) End If Set objFirst = Evaluate(objCode.Item(0), objEnv) - Set varRet = objFirst.Apply(objCode, objEnv) + If objFirst.IsMacro Then + Set varRet = objFirst.MacroApply(objCode, objEnv) + Else + Set varRet = objFirst.Apply(objCode, objEnv) + End If Else Set varRet = EvaluateAST(objCode, objEnv) End If @@ -398,7 +377,11 @@ Function EvaluateAST(objCode, objEnv) Dim varRet, i Select Case objCode.Type Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) + Set varRet = objEnv.Get(objCode.Value) + if TypeName(varRet) = "Nothing" Then + Err.Raise vbObjectError, _ + "Environment", "'" + objCode.Value + "' not found" + End If Case TYPES.LIST Err.Raise vbObjectError, _ "EvaluateAST", "Unexpect type." diff --git a/impls/vbs/step9_try.vbs b/impls/vbs/step9_try.vbs index b4c47d6603..ef4571636f 100644 --- a/impls/vbs/step9_try.vbs +++ b/impls/vbs/step9_try.vbs @@ -160,7 +160,6 @@ Function MQuasiQuoteExpand(objArgs, objEnv) Set MQuasiQuoteExpand = varRes End Function -objNS.Add NewMalSym("quasiquoteexpand"), NewVbsProc("MQuasiQuoteExpand", True) Class ExpandType Public Splice @@ -267,47 +266,6 @@ Function MDefMacro(objArgs, objEnv) 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 @@ -424,6 +382,23 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function +Sub DebugEval(objCode, objEnv) + Dim value, bool + Set value = objEnv.Get("DEBUG-EVAL") + If TypeName(value) = "Nothing" Then + Set bool = False + Else + If value.Type = TYPES.BOOLEAN Then + Set bool = value.Value + Else + Set bool = value.Type <> TYPES.NIL + End If + End If + If bool Then + IO.WriteLine "EVAL: " + PrintMalType(objCode, True) + End If +End Sub + Function Evaluate(ByVal objCode, ByVal objEnv) While True If TypeName(objCode) = "Nothing" Then @@ -431,7 +406,7 @@ Function Evaluate(ByVal objCode, ByVal objEnv) Exit Function End If - Set objCode = MacroExpand(objCode, objEnv) + DebugEval objCode, objEnv Dim varRet, objFirst If objCode.Type = TYPES.LIST Then @@ -441,7 +416,11 @@ Function Evaluate(ByVal objCode, ByVal objEnv) End If Set objFirst = Evaluate(objCode.Item(0), objEnv) - Set varRet = objFirst.Apply(objCode, objEnv) + If objFirst.IsMacro Then + Set varRet = objFirst.MacroApply(objCode, objEnv) + Else + Set varRet = objFirst.Apply(objCode, objEnv) + End If Else Set varRet = EvaluateAST(objCode, objEnv) End If @@ -464,7 +443,11 @@ Function EvaluateAST(objCode, objEnv) Dim varRet, i Select Case objCode.Type Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) + Set varRet = objEnv.Get(objCode.Value) + if TypeName(varRet) = "Nothing" Then + Err.Raise vbObjectError, _ + "Environment", "'" + objCode.Value + "' not found" + End If Case TYPES.LIST Err.Raise vbObjectError, _ "EvaluateAST", "Unexpect type." diff --git a/impls/vbs/stepA_mal.vbs b/impls/vbs/stepA_mal.vbs index 8a53b75013..983c2f9f91 100644 --- a/impls/vbs/stepA_mal.vbs +++ b/impls/vbs/stepA_mal.vbs @@ -160,7 +160,6 @@ Function MQuasiQuoteExpand(objArgs, objEnv) Set MQuasiQuoteExpand = varRes End Function -objNS.Add NewMalSym("quasiquoteexpand"), NewVbsProc("MQuasiQuoteExpand", True) Class ExpandType Public Splice @@ -267,47 +266,6 @@ Function MDefMacro(objArgs, objEnv) 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 @@ -425,6 +383,23 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function +Sub DebugEval(objCode, objEnv) + Dim value, bool + Set value = objEnv.Get("DEBUG-EVAL") + If TypeName(value) = "Nothing" Then + Set bool = False + Else + If value.Type = TYPES.BOOLEAN Then + Set bool = value.Value + Else + Set bool = value.Type <> TYPES.NIL + End If + End If + If bool Then + IO.WriteLine "EVAL: " + PrintMalType(objCode, True) + End If +End Sub + Function Evaluate(ByVal objCode, ByVal objEnv) While True If TypeName(objCode) = "Nothing" Then @@ -432,7 +407,7 @@ Function Evaluate(ByVal objCode, ByVal objEnv) Exit Function End If - Set objCode = MacroExpand(objCode, objEnv) + DebugEval objCode, objEnv Dim varRet, objFirst If objCode.Type = TYPES.LIST Then @@ -442,7 +417,11 @@ Function Evaluate(ByVal objCode, ByVal objEnv) End If Set objFirst = Evaluate(objCode.Item(0), objEnv) - Set varRet = objFirst.Apply(objCode, objEnv) + If objFirst.IsMacro Then + Set varRet = objFirst.MacroApply(objCode, objEnv) + Else + Set varRet = objFirst.Apply(objCode, objEnv) + End If Else Set varRet = EvaluateAST(objCode, objEnv) End If @@ -465,7 +444,11 @@ Function EvaluateAST(objCode, objEnv) Dim varRet, i Select Case objCode.Type Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) + Set varRet = objEnv.Get(objCode.Value) + if TypeName(varRet) = "Nothing" Then + Err.Raise vbObjectError, _ + "Environment", "'" + objCode.Value + "' not found" + End If Case TYPES.LIST Err.Raise vbObjectError, _ "EvaluateAST", "Unexpect type." diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index 0c08c95e8f..64bd6c6b76 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -525,7 +525,7 @@ Class MalProcedure 'Extends MalType Wend ' EvalLater -> Evaluate - Set varRet = Evaluate(objCode, objNewEnv) + Set varRet = EvalLater(objCode, objNewEnv) Set MacroApply = varRet End Function