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.
kanaka · Oct 22, 2024 · 53c23e3 · 53c23e3
1 parent ac666a1
commit 53c23e3
Show file tree

Hide file tree

Showing 10 changed files with 212 additions and 160 deletions.
diff --git 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
diff --git 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
@@ -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
@@ -152,13 +152,32 @@ 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
 			Set Evaluate = Nothing
 			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
@@ -180,13 +180,32 @@ 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
 			Set Evaluate = Nothing
 			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
@@ -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,13 +303,32 @@ 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
 			Set Evaluate = Nothing
 			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
@@ -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,14 +316,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(ByVal objCode, ByVal objEnv)
 	While True
 		If TypeName(objCode) = "Nothing" Then
 			Set Evaluate = Nothing
 			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."