From 936e20ea2ea2414bf607f06c257484a169ae9899 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Mon, 10 Jan 2022 00:07:07 +0800 Subject: [PATCH 01/44] batch impl init --- impls/batch/reader.bat | 64 +++++++++++++++++++++ impls/batch/step0_repl.bat | 112 +++++++++++++++++++++++++++++++++++++ 2 files changed, 176 insertions(+) create mode 100644 impls/batch/reader.bat create mode 100644 impls/batch/step0_repl.bat diff --git a/impls/batch/reader.bat b/impls/batch/reader.bat new file mode 100644 index 00000000..20d432fb --- /dev/null +++ b/impls/batch/reader.bat @@ -0,0 +1,64 @@ +:: Code by OldLiu +:: using batch to achieve this program is a big challenge, but I still done it. +:: I hope you like it, lol. + + +::Start + Set "_TMP_Arguments_=%*" + If "!_TMP_Arguments_:~,1!" Equ ":" ( + Set "_TMP_Arguments_=!_TMP_Arguments_:~1!" + ) + Call :!_TMP_Arguments_! + Set _TMP_Arguments_= +Goto :Eof + +:read_str + setlocal + for %%a in ("!re!") do ( + endlocal + set "re=%%~a" + ) +goto :eof + + +:read_form code + setlocal + set "code=%~1" + call :_delete_space code + if "!code:~,1!" == "(" ( + call :read_list "!code:~1!" + ) else ( + call :read_atom "!code:~1!" + ) + for %%a in ("!re!") do ( + endlocal + set "re=%%~a" + ) +goto :eof + +:read_list code + setlocal + set "code=%~1" + call :_delete_space code + for %%a in ("!re!") do ( + endlocal + set "re=%%~a" + ) +goto :eof + +:read_atom code + setlocal + set "code=%~1" + call :_delete_space code + for %%a in ("!re!") do ( + endlocal + set "re=%%~a" + ) +goto :eof + +:_delete_space var + if "!%1:~,1!" == " " ( + set "%1=!%1:~1!" + goto :_delete_space + ) +goto :eof \ No newline at end of file diff --git a/impls/batch/step0_repl.bat b/impls/batch/step0_repl.bat new file mode 100644 index 00000000..223b305b --- /dev/null +++ b/impls/batch/step0_repl.bat @@ -0,0 +1,112 @@ +:: Code by OldLiu +:: using batch to achieve this program is a big challenge, but I still done it. +:: I hope you like it, lol. + +@echo off +setlocal disabledelayedexpansion +for /f "delims==" %%a in ('set') do set "%%a=" + +:main + set input= + set /p "input=user> " + if defined input ( + rem first replace double quotation mark. + set "input=%input:"=This_is_a_double_quotation_mark,lol%" + rem Batch can't deal with "!" when delayed expansion is enabled, so replace it to a special string. + call set "input=%%input:!=This_is_a_Exclamation_Mark,lol%%" + setlocal ENABLEDELAYEDEXPANSION + %improve speed start% ( + rem Batch has some proble in "^" processing, so replace it. + set "input=!input:^=This_is_a_caret,lol!" + rem replace %. + set input_formated= + rem set input + :replacement_loop + if defined input ( + if "!input:~,1!" == "%%" ( + set "input_formated=!input_formated!This_is_a_percent_symbol,lol" + ) else ( + set "input_formated=!input_formated!!input:~,1!" + ) + set "input=!input:~1!" + goto replacement_loop + ) + rem set input + call :rep "!input_formated!" + endlocal + ) %improve speed end% + ) +goto :main + + +%improve speed start% ( + :READ + setlocal + rem re means return, which bring return value. + set "re=%~1" + for /f "delims=" %%a in ("!re!") do ( + endlocal + set "re=%%~a" + ) + goto :eof + + :EVAL + setlocal + set "re=%~1" + for /f "delims=" %%a in ("!re!") do ( + endlocal + set "re=%%~a" + ) + goto :eof + + :PRINT + setlocal + set "output=%~1" + rem replace all speical symbol back. + set output_buffer= + :output_loop + if "!output:~,30!" == "This_is_a_Exclamation_Mark,lol" ( + set "output_buffer=!output_buffer!^!" + set "output=!output:~30!" + goto output_loop + ) else if "!output:~,19!" == "This_is_a_caret,lol" ( + set "output_buffer=!output_buffer!^^" + set "output=!output:~19!" + goto output_loop + ) else if "!output:~,35!" == "This_is_a_double_quotation_mark,lol" ( + set "output_buffer=!output_buffer!^"" + set "output=!output:~35!" + goto output_loop + ) else if "!output:~,1!" == "=" ( + set "output_buffer=!output_buffer!=" + set "output=!output:~1!" + goto output_loop + ) else if "!output:~,1!" == " " ( + set "output_buffer=!output_buffer! " + set "output=!output:~1!" + goto output_loop + ) else if "!output:~,28!" == "This_is_a_percent_symbol,lol" ( + set "output_buffer=!output_buffer!%%" + set "output=!output:~28!" + goto output_loop + ) else if defined output ( + set "output_buffer=!output_buffer!!output:~,1!" + set "output=!output:~1!" + goto output_loop + ) + echo.!output_buffer! + set "re=%~1" + for /f "delims=" %%a in ("!re!") do ( + endlocal + set "re=%%~a" + ) + goto :eof + + :rep + setlocal + call :READ "%~1" + call :EVAL "!re!" + call :PRINT "!re!" + endlocal + goto :eof +) %improve speed end% \ No newline at end of file From b02c2c74c67992933c0599d799f1270085f04117 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Thu, 17 Feb 2022 23:02:57 +0800 Subject: [PATCH 02/44] vbs step 0&1 --- impls/batch/reader.bat | 64 ------------------- impls/batch/step0_repl.bat | 112 --------------------------------- impls/vbs/printer.vbs | 25 ++++++++ impls/vbs/reader.vbs | 65 +++++++++++++++++++ impls/vbs/step0_repl.vbs | 21 +++++++ impls/vbs/step1_read_print.vbs | 36 +++++++++++ 6 files changed, 147 insertions(+), 176 deletions(-) delete mode 100644 impls/batch/reader.bat delete mode 100644 impls/batch/step0_repl.bat create mode 100644 impls/vbs/printer.vbs create mode 100644 impls/vbs/reader.vbs create mode 100644 impls/vbs/step0_repl.vbs create mode 100644 impls/vbs/step1_read_print.vbs diff --git a/impls/batch/reader.bat b/impls/batch/reader.bat deleted file mode 100644 index 20d432fb..00000000 --- a/impls/batch/reader.bat +++ /dev/null @@ -1,64 +0,0 @@ -:: Code by OldLiu -:: using batch to achieve this program is a big challenge, but I still done it. -:: I hope you like it, lol. - - -::Start - Set "_TMP_Arguments_=%*" - If "!_TMP_Arguments_:~,1!" Equ ":" ( - Set "_TMP_Arguments_=!_TMP_Arguments_:~1!" - ) - Call :!_TMP_Arguments_! - Set _TMP_Arguments_= -Goto :Eof - -:read_str - setlocal - for %%a in ("!re!") do ( - endlocal - set "re=%%~a" - ) -goto :eof - - -:read_form code - setlocal - set "code=%~1" - call :_delete_space code - if "!code:~,1!" == "(" ( - call :read_list "!code:~1!" - ) else ( - call :read_atom "!code:~1!" - ) - for %%a in ("!re!") do ( - endlocal - set "re=%%~a" - ) -goto :eof - -:read_list code - setlocal - set "code=%~1" - call :_delete_space code - for %%a in ("!re!") do ( - endlocal - set "re=%%~a" - ) -goto :eof - -:read_atom code - setlocal - set "code=%~1" - call :_delete_space code - for %%a in ("!re!") do ( - endlocal - set "re=%%~a" - ) -goto :eof - -:_delete_space var - if "!%1:~,1!" == " " ( - set "%1=!%1:~1!" - goto :_delete_space - ) -goto :eof \ No newline at end of file diff --git a/impls/batch/step0_repl.bat b/impls/batch/step0_repl.bat deleted file mode 100644 index 223b305b..00000000 --- a/impls/batch/step0_repl.bat +++ /dev/null @@ -1,112 +0,0 @@ -:: Code by OldLiu -:: using batch to achieve this program is a big challenge, but I still done it. -:: I hope you like it, lol. - -@echo off -setlocal disabledelayedexpansion -for /f "delims==" %%a in ('set') do set "%%a=" - -:main - set input= - set /p "input=user> " - if defined input ( - rem first replace double quotation mark. - set "input=%input:"=This_is_a_double_quotation_mark,lol%" - rem Batch can't deal with "!" when delayed expansion is enabled, so replace it to a special string. - call set "input=%%input:!=This_is_a_Exclamation_Mark,lol%%" - setlocal ENABLEDELAYEDEXPANSION - %improve speed start% ( - rem Batch has some proble in "^" processing, so replace it. - set "input=!input:^=This_is_a_caret,lol!" - rem replace %. - set input_formated= - rem set input - :replacement_loop - if defined input ( - if "!input:~,1!" == "%%" ( - set "input_formated=!input_formated!This_is_a_percent_symbol,lol" - ) else ( - set "input_formated=!input_formated!!input:~,1!" - ) - set "input=!input:~1!" - goto replacement_loop - ) - rem set input - call :rep "!input_formated!" - endlocal - ) %improve speed end% - ) -goto :main - - -%improve speed start% ( - :READ - setlocal - rem re means return, which bring return value. - set "re=%~1" - for /f "delims=" %%a in ("!re!") do ( - endlocal - set "re=%%~a" - ) - goto :eof - - :EVAL - setlocal - set "re=%~1" - for /f "delims=" %%a in ("!re!") do ( - endlocal - set "re=%%~a" - ) - goto :eof - - :PRINT - setlocal - set "output=%~1" - rem replace all speical symbol back. - set output_buffer= - :output_loop - if "!output:~,30!" == "This_is_a_Exclamation_Mark,lol" ( - set "output_buffer=!output_buffer!^!" - set "output=!output:~30!" - goto output_loop - ) else if "!output:~,19!" == "This_is_a_caret,lol" ( - set "output_buffer=!output_buffer!^^" - set "output=!output:~19!" - goto output_loop - ) else if "!output:~,35!" == "This_is_a_double_quotation_mark,lol" ( - set "output_buffer=!output_buffer!^"" - set "output=!output:~35!" - goto output_loop - ) else if "!output:~,1!" == "=" ( - set "output_buffer=!output_buffer!=" - set "output=!output:~1!" - goto output_loop - ) else if "!output:~,1!" == " " ( - set "output_buffer=!output_buffer! " - set "output=!output:~1!" - goto output_loop - ) else if "!output:~,28!" == "This_is_a_percent_symbol,lol" ( - set "output_buffer=!output_buffer!%%" - set "output=!output:~28!" - goto output_loop - ) else if defined output ( - set "output_buffer=!output_buffer!!output:~,1!" - set "output=!output:~1!" - goto output_loop - ) - echo.!output_buffer! - set "re=%~1" - for /f "delims=" %%a in ("!re!") do ( - endlocal - set "re=%%~a" - ) - goto :eof - - :rep - setlocal - call :READ "%~1" - call :EVAL "!re!" - call :PRINT "!re!" - endlocal - goto :eof -) %improve speed end% \ No newline at end of file diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs new file mode 100644 index 00000000..505aa298 --- /dev/null +++ b/impls/vbs/printer.vbs @@ -0,0 +1,25 @@ +Function pr_str(o) + If typename(o) = "ArrayList" Then + pr_str ="(" + bool = False + For Each item In o + bool = True + pr_str =pr_str & pr_str(item) & " " + Next + if bool then + pr_str = left(pr_str,len(pr_str)-1) & ")" + else + pr_str = "()" + End If + Else + pr_str = o.value_ + End If +End Function + + +' set list = CreateObject("System.Collections.ArrayList") +' list.add(3) +' for each i in list +' msgbox i +' next + diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs new file mode 100644 index 00000000..0c2a14b6 --- /dev/null +++ b/impls/vbs/reader.vbs @@ -0,0 +1,65 @@ +Class MalType + Public Type_ + Public value_ +End Class + + +'msgbox pr_str(read_str("(123 (456, 567))")) +'msgbox typename(CreateObject("System.Collections.ArrayList")) + +Function read_str(str) + set read_str=read_form(tokenize(str)) +End Function + +Function tokenize(str) + Set oQueue = CreateObject("System.Collections.Queue") + Set regEx = New RegExp + regEx.Pattern = "[\s,]*(~@|[\[\]{}()'`~^@]|""(?:\\.|[^\\""])*""?|;.*|[^\s\[\]{}('""`,;)]*)" + regEx.IgnoreCase = True + regEx.Global = True + Set Matches = regEx.Execute(str) + For Each Match In Matches + 'msgbox Match.SubMatches(0) + oQueue.Enqueue(Match.SubMatches(0)) + Next + Set regEx = Nothing + Set Matches = Nothing + Set tokenize = oQueue +End Function + +Function read_form(oQueue) + If oQueue.Peek() = "(" Then + set read_form = read_list(oQueue) + Else + set read_form = read_atom(oQueue) + End If +End Function + +Function read_list(oQueue) + oQueue.Dequeue() + + set read_list = CreateObject("System.Collections.ArrayList") + + While oQueue.count <> 0 And oQueue.Peek() <> ")" + read_list.Add read_form(oQueue) + Wend + If oQueue.count <> 0 Then + oQueue.Dequeue() + End If +End Function + +Function read_atom(oQueue) + atom = oQueue.Dequeue() + if isnumeric(atom) Then + set read_atom = new MalType + read_atom.Type_ = "number" + read_atom.value_ = atom + else + set read_atom = new MalType + read_atom.Type_ = "symbol" + read_atom.value_ = atom + End If +End Function + + +'msgbox pr_str(read_str("1")) \ No newline at end of file diff --git a/impls/vbs/step0_repl.vbs b/impls/vbs/step0_repl.vbs new file mode 100644 index 00000000..4143b3e3 --- /dev/null +++ b/impls/vbs/step0_repl.vbs @@ -0,0 +1,21 @@ +Function READ(str) + READ = str +End Function + +Function EVAL(str) + EVAL = str +End Function + +Function PRINT(str) + PRINT = str +End Function + +Function rep(str) + rep = PRINT(EVAL(READ(str))) +End Function + +While True + WScript.StdOut.Write("user> ") + code = WScript.StdIn.ReadLine() + WScript.Echo(rep(code)) +WEnd diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs new file mode 100644 index 00000000..bc592b05 --- /dev/null +++ b/impls/vbs/step1_read_print.vbs @@ -0,0 +1,36 @@ +Include "reader.vbs" +Include "printer.vbs" + +Function READ(str) + set READ = read_str(str) +End Function + +Function EVAL(oMal) + set EVAL = oMal +End Function + +Function PRINT(oMal) + PRINT = pr_str(oMal) +End Function + +Function rep(str) + rep = PRINT(EVAL(READ(str))) +End Function + +While True + WScript.StdOut.Write("user> ") + code = WScript.StdIn.ReadLine() + WScript.Echo(rep(code)) +WEnd + +Sub Include(sInstFile) + Dim oFSO, f, s + Set oFSO = CreateObject("Scripting.FileSystemObject") + sInstFile = oFSO.GetParentFolderName(oFSO.GetFile(Wscript.ScriptFullName)) & "\" & sInstFile + Set f = oFSO.OpenTextFile(sInstFile) + s = f.ReadAll + f.Close + Set f = Nothing + Set oFSO = Nothing + ExecuteGlobal s +End Sub \ No newline at end of file From 24dd8072d34bdc2dc6764161ff6376555d26e224 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Fri, 18 Feb 2022 12:00:05 +0800 Subject: [PATCH 03/44] add error handling,macros, string, boolean, null --- impls/vbs/printer.vbs | 31 +++++----- impls/vbs/reader.vbs | 106 ++++++++++++++++++++++++++++++--- impls/vbs/step1_read_print.vbs | 5 +- 3 files changed, 118 insertions(+), 24 deletions(-) diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs index 505aa298..a69d5c90 100644 --- a/impls/vbs/printer.vbs +++ b/impls/vbs/printer.vbs @@ -1,19 +1,22 @@ -Function pr_str(o) - If typename(o) = "ArrayList" Then - pr_str ="(" - bool = False - For Each item In o - bool = True - pr_str =pr_str & pr_str(item) & " " - Next - if bool then - pr_str = left(pr_str,len(pr_str)-1) & ")" - else - pr_str = "()" +Function pr_str(o,print_readably) + if not print_readably then + If left(o.type_,4) = "list" Then + pr_str =mid(o.type_,5,1) + bool = False + For Each item In o.value_ + bool = True + pr_str =pr_str & pr_str(item,print_readably) & " " + Next + if bool then + pr_str = left(pr_str,len(pr_str)-1) & mid(o.type_,6,1) + else + pr_str = mid(o.type_,5,2) + End If + Else + pr_str = o.value_ End If Else - pr_str = o.value_ - End If + end if End Function diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index 0c2a14b6..33a0814c 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -20,7 +20,9 @@ Function tokenize(str) Set Matches = regEx.Execute(str) For Each Match In Matches 'msgbox Match.SubMatches(0) - oQueue.Enqueue(Match.SubMatches(0)) + if not left(Match.SubMatches(0), 1) = ";" then + oQueue.Enqueue(Match.SubMatches(0)) + End if Next Set regEx = Nothing Set Matches = Nothing @@ -28,23 +30,74 @@ Function tokenize(str) End Function Function read_form(oQueue) - If oQueue.Peek() = "(" Then + if oQueue.Count = 0 then + Set read_form = Nothing + exit function + end if + If oQueue.Peek() = "(" or oQueue.Peek() = "[" or oQueue.Peek() = "{" Then set read_form = read_list(oQueue) + elseif oQueue.Peek() = "'" or oQueue.Peek() = "`" or oQueue.Peek() = "~" or oQueue.Peek() = "~@" or oQueue.Peek = "@" then + select case oQueue.Dequeue() + case "'" + s = "quote" + case "`" + s = "quasiquote" + case "~" + s = "unquote" + case "~@" + s = "splice-unquote" + case "@" + s = "deref" + end select + set o = new MalType + o.Type_ = "symbol" + o.value_ = s + set l = new MalType + l.Type_ = "list()" + set l.value_ = CreateObject("System.Collections.ArrayList") + l.value_.Add(o) + l.value_.Add(read_form(oQueue)) + set read_form = l + elseif oQueue.Peek() = ")" or oQueue.Peek() = "]" or oQueue.Peek() = "}" then + Set read_form = Nothing + err.Raise vbObjectError, "read_form", "unbalanced parentheses" + elseif oQueue.Peek() = "^" then + oQueue.Dequeue() + set o = new MalType + o.Type_ = "symbol" + o.value_ = "with-meta" + set l = new MalType + l.Type_ = "list()" + set l.value_ = CreateObject("System.Collections.ArrayList") + l.value_.Add(o) + set tmp = read_form(oQueue) + l.value_.Add(read_form(oQueue)) + l.value_.Add(tmp) + set read_form = l Else set read_form = read_atom(oQueue) End If End Function Function read_list(oQueue) - oQueue.Dequeue() + p = oQueue.Dequeue() + if p = "(" Then + q = ")" + elseif p = "[" then + q = "]" + elseif p = "{" then + q = "}" + end if - set read_list = CreateObject("System.Collections.ArrayList") + set read_list = new MalType + set read_list.value_ = CreateObject("System.Collections.ArrayList") + read_list.type_ = "list"+p+q - While oQueue.count <> 0 And oQueue.Peek() <> ")" - read_list.Add read_form(oQueue) + While oQueue.count > 1 And oQueue.Peek() <> q + read_list.value_.Add read_form(oQueue) Wend - If oQueue.count <> 0 Then - oQueue.Dequeue() + If oQueue.Dequeue() <> q Then + err.raise vbObjectError,"reader", "excepted '"+q+"', got EOF" End If End Function @@ -54,6 +107,42 @@ Function read_atom(oQueue) set read_atom = new MalType read_atom.Type_ = "number" read_atom.value_ = atom + elseif atom = "true" or atom = "false" Then + set read_atom = new MalType + read_atom.Type_ = "boolean" + read_atom.value_ = atom + elseif left(atom,1) = """" Then + if (not right(atom,1) = """") or len(atom) = 1 then err.raise vbObjectError,"reader", "Unterminated string" + set read_atom = new MalType + read_atom.Type_ = "string" + str_tmp = "" + for i = 2 to len(atom) - 1 + if backslash then + backslash = False + 'msgbox backslash + if mid(atom,i,1) = "n" then + str_tmp = str_tmp + vbnewline + elseif mid(atom,i,1) = "\" then + str_tmp = str_tmp + "\" + elseif mid(atom,i,1) = """" then + str_tmp = str_tmp + """" + end if + else + if mid(atom,i,1) = "\" then + backslash = True + else + str_tmp = str_tmp + mid(atom,i,1) + end if + end if + next + if backslash then err.raise vbObjectError,"reader", "Unterminated string" + read_atom.value_ = """" + str_tmp + """" + elseif atom = "nil" Then + set read_atom = new MalType + read_atom.Type_ = "null" + read_atom.value_ = atom + elseif left(atom,1) = ";" Then + set read_atom = nothing else set read_atom = new MalType read_atom.Type_ = "symbol" @@ -62,4 +151,3 @@ Function read_atom(oQueue) End Function -'msgbox pr_str(read_str("1")) \ No newline at end of file diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs index bc592b05..3e47f792 100644 --- a/impls/vbs/step1_read_print.vbs +++ b/impls/vbs/step1_read_print.vbs @@ -10,11 +10,14 @@ Function EVAL(oMal) End Function Function PRINT(oMal) - PRINT = pr_str(oMal) + PRINT = pr_str(oMal,false) End Function Function rep(str) + on error resume next rep = PRINT(EVAL(READ(str))) + if err.number <> 0 then rep = err.description + on error goto 0 End Function While True From 50dab06a91742caaae382d25ac6ada52e9fffea2 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Fri, 18 Feb 2022 12:14:44 +0800 Subject: [PATCH 04/44] add extra code data detect --- impls/vbs/reader.vbs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index 33a0814c..e2c5287a 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -8,7 +8,7 @@ End Class 'msgbox typename(CreateObject("System.Collections.ArrayList")) Function read_str(str) - set read_str=read_form(tokenize(str)) + set read_str=read_form_(tokenize(str)) End Function Function tokenize(str) @@ -29,6 +29,13 @@ Function tokenize(str) Set tokenize = oQueue End Function +Function read_form_(oQueue) + set read_form_=read_form(oQueue) + if oQueue.Count > 0 then + err.raise vbObjectError,"SyntaxError", "Extra data after form: " + oQueue.Dequeue + end if +End Function + Function read_form(oQueue) if oQueue.Count = 0 then Set read_form = Nothing @@ -77,6 +84,7 @@ Function read_form(oQueue) Else set read_form = read_atom(oQueue) End If + End Function Function read_list(oQueue) @@ -99,6 +107,7 @@ Function read_list(oQueue) If oQueue.Dequeue() <> q Then err.raise vbObjectError,"reader", "excepted '"+q+"', got EOF" End If + 'msgbox oQueue.peek End Function Function read_atom(oQueue) From a43da3649a2a41fdb4baaff06eaad07c852c5157 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sat, 26 Feb 2022 10:52:44 +0800 Subject: [PATCH 05/44] fix hashtable, string, error handle --- impls/vbs/printer.vbs | 52 +++++++++++++++++++++---------- impls/vbs/reader.vbs | 56 ++++++++++++++++++++++++++++++---- impls/vbs/step1_read_print.vbs | 2 +- 3 files changed, 87 insertions(+), 23 deletions(-) diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs index a69d5c90..a10511b4 100644 --- a/impls/vbs/printer.vbs +++ b/impls/vbs/printer.vbs @@ -1,22 +1,42 @@ Function pr_str(o,print_readably) - if not print_readably then - If left(o.type_,4) = "list" Then - pr_str =mid(o.type_,5,1) - bool = False - For Each item In o.value_ - bool = True - pr_str =pr_str & pr_str(item,print_readably) & " " - Next - if bool then - pr_str = left(pr_str,len(pr_str)-1) & mid(o.type_,6,1) - else - pr_str = mid(o.type_,5,2) - End If - Else - pr_str = o.value_ + If left(o.type_,4) = "list" Then + pr_str =mid(o.type_,5,1) + bool = False + For Each item In o.value_ + bool = True + pr_str =pr_str & pr_str(item,print_readably) & " " + Next + if bool then + pr_str = left(pr_str,len(pr_str)-1) & mid(o.type_,6,1) + else + pr_str = mid(o.type_,5,2) + End If + elseif o.type_ = "hash-map" Then + pr_str = "{" + bool = False + For each item in o.value_ + bool = True + pr_str =pr_str & pr_str(item,print_readably) & " " & pr_str(o.value_.item(item),print_readably) & " " + Next + if bool then + pr_str = left(pr_str,len(pr_str)-1) & "}" + else + pr_str = "{}" End If Else - end if + if print_readably and o.type_="string" then + pr_str = o.value_ + pr_str = replace(pr_str,"\","\\") + pr_str = replace(pr_str,vbnewline,"\n") + pr_str = replace(pr_str,"""","\""") + pr_str = """" & pr_str & """" + Elseif o.type_="string" then + pr_str = """" & o.value_ & """" + else + pr_str = o.value_ + End If + End If + End Function diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index e2c5287a..906f6f33 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -1,3 +1,5 @@ +Include "printer.vbs" + Class MalType Public Type_ Public value_ @@ -6,9 +8,9 @@ End Class 'msgbox pr_str(read_str("(123 (456, 567))")) 'msgbox typename(CreateObject("System.Collections.ArrayList")) - +'msgbox pr_str(read_str("(123 ")) Function read_str(str) - set read_str=read_form_(tokenize(str)) + set read_str=read_form(tokenize(str)) End Function Function tokenize(str) @@ -42,7 +44,13 @@ Function read_form(oQueue) exit function end if If oQueue.Peek() = "(" or oQueue.Peek() = "[" or oQueue.Peek() = "{" Then - set read_form = read_list(oQueue) + if oQueue.Peek() = "(" then + Set read_form = read_list(oQueue) + elseif oQueue.Peek() = "[" then + Set read_form = read_vector(oQueue) + elseif oQueue.Peek() = "{" then + Set read_form = read_hash_map(oQueue) + end if elseif oQueue.Peek() = "'" or oQueue.Peek() = "`" or oQueue.Peek() = "~" or oQueue.Peek() = "~@" or oQueue.Peek = "@" then select case oQueue.Dequeue() case "'" @@ -110,6 +118,27 @@ Function read_list(oQueue) 'msgbox oQueue.peek End Function +function read_vector(oQueue) + set read_vector = read_list(oQueue) +end function + +function read_hash_map(oQueue) + oQueue.Dequeue() + set read_hash_map = new MalType + set read_hash_map.value_ = CreateObject("Scripting.Dictionary") + + read_hash_map.type_ = "hash-map" + While oQueue.count > 1 And oQueue.Peek() <> "}" + set key = read_form(oQueue) + read_hash_map.value_.Add key, read_form(oQueue) + Wend + If oQueue.Dequeue() <> "}" Then + err.raise vbObjectError,"reader", "excepted '}', got EOF" + End If +End Function + + + Function read_atom(oQueue) atom = oQueue.Dequeue() if isnumeric(atom) Then @@ -121,7 +150,7 @@ Function read_atom(oQueue) read_atom.Type_ = "boolean" read_atom.value_ = atom elseif left(atom,1) = """" Then - if (not right(atom,1) = """") or len(atom) = 1 then err.raise vbObjectError,"reader", "Unterminated string" + if (not right(atom,1) = """") or len(atom) = 1 then err.raise vbObjectError,"reader", "Unterminated string, got EOF" set read_atom = new MalType read_atom.Type_ = "string" str_tmp = "" @@ -144,12 +173,16 @@ Function read_atom(oQueue) end if end if next - if backslash then err.raise vbObjectError,"reader", "Unterminated string" - read_atom.value_ = """" + str_tmp + """" + if backslash then err.raise vbObjectError,"reader", "Unterminated string, got EOF" + read_atom.value_ = str_tmp elseif atom = "nil" Then set read_atom = new MalType read_atom.Type_ = "null" read_atom.value_ = atom + elseif left(atom,1) = ":" Then + set read_atom = new MalType + read_atom.Type_ = "keyword" + read_atom.value_ = atom elseif left(atom,1) = ";" Then set read_atom = nothing else @@ -160,3 +193,14 @@ Function read_atom(oQueue) End Function +Sub Include(sInstFile) + Dim oFSO, f, s + Set oFSO = CreateObject("Scripting.FileSystemObject") + sInstFile = oFSO.GetParentFolderName(oFSO.GetFile(Wscript.ScriptFullName)) & "\" & sInstFile + Set f = oFSO.OpenTextFile(sInstFile) + s = f.ReadAll + f.Close + Set f = Nothing + Set oFSO = Nothing + ExecuteGlobal s +End Sub \ No newline at end of file diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs index 3e47f792..00fb020e 100644 --- a/impls/vbs/step1_read_print.vbs +++ b/impls/vbs/step1_read_print.vbs @@ -10,7 +10,7 @@ Function EVAL(oMal) End Function Function PRINT(oMal) - PRINT = pr_str(oMal,false) + PRINT = pr_str(oMal,true) End Function Function rep(str) From 8b4eefdbc8ae5c6282b3e71a7026fc67f65af740 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Mon, 2 May 2022 10:52:27 +0800 Subject: [PATCH 06/44] finish step2 --- impls/vbs/printer.vbs | 5 ++ impls/vbs/reader.vbs | 9 ++- impls/vbs/step2_eval.vbs | 140 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 152 insertions(+), 2 deletions(-) create mode 100644 impls/vbs/step2_eval.vbs diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs index a10511b4..d0a818df 100644 --- a/impls/vbs/printer.vbs +++ b/impls/vbs/printer.vbs @@ -1,4 +1,9 @@ Function pr_str(o,print_readably) + msgbox typename(o) = "Nothing" + if typename(o) = "Nothing" then + pr_str = "" + exit function + end if If left(o.type_,4) = "list" Then pr_str =mid(o.type_,5,1) bool = False diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index 906f6f33..71173a6d 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -11,6 +11,7 @@ End Class 'msgbox pr_str(read_str("(123 ")) Function read_str(str) set read_str=read_form(tokenize(str)) + 'msgbox pr_str(read_str,true) End Function Function tokenize(str) @@ -33,6 +34,7 @@ End Function Function read_form_(oQueue) set read_form_=read_form(oQueue) + 'msgbox pr_str(read_form_),true if oQueue.Count > 0 then err.raise vbObjectError,"SyntaxError", "Extra data after form: " + oQueue.Dequeue end if @@ -141,10 +143,13 @@ End Function Function read_atom(oQueue) atom = oQueue.Dequeue() - if isnumeric(atom) Then + if atom = "" then + set read_atom = Nothing + elseif isnumeric(atom) Then set read_atom = new MalType read_atom.Type_ = "number" - read_atom.value_ = atom + read_atom.value_ = cdbl(atom) + 'msgbox "here" elseif atom = "true" or atom = "false" Then set read_atom = new MalType read_atom.Type_ = "boolean" diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs new file mode 100644 index 00000000..a50ad4c4 --- /dev/null +++ b/impls/vbs/step2_eval.vbs @@ -0,0 +1,140 @@ +Include "reader.vbs" +Include "printer.vbs" + +function add(args) + set add = new MalType + add.type_ = "number" + 'msgbox typename(args) + add.value_ = args.value_.item(1).value_ + args.value_.item(2).value_ +end function + +function subtract(args) + set subtract = new MalType + subtract.type_ = "number" + subtract.value_ = args.value_.item(1).value_ - args.value_.item(2).value_ +end function + +function multiply(args) + set multiply = new MalType + multiply.type_ = "number" + multiply.value_ = args.value_.item(1).value_ * args.value_.item(2).value_ +end function + +function divide(args) + set divide = new MalType + divide.type_ = "number" + divide.value_ = args.value_.item(1).value_ / args.value_.item(2).value_ +end function + +function donothing(args) + set donothing = new MalType + donothing.type_ = "nil" + donothing.value_ = "error" +end function + +class enviroment + public env + private sub Class_Initialize() + set env = CreateObject("Scripting.Dictionary") + env.add "+",getref("add") + env.add "-",getref("subtract") + env.add "*",getref("multiply") + env.add "/",getref("divide") + env.add "donothing", getref("donothing") + end sub + +end class + +Function READ(str) + set READ = read_str(str) +End Function + +Function EVAL(oMal,env) + 'msgbox typename(o) + if isempty(o) then + set EVAL = donothing("") + exit function + end if + select case oMal.type_ + case "list()" + if oMal.value_.count = 0 then + set EVAL = oMal + else + 'wsh.echo oMal.value_.item(0).value_ + 'wsh.echo typename(env.env) + 'msgbox eval_ast(oMal.value_.item(1),env).value_ + 'msgbox typename(env.env.item("+")(oMal)) + 'if not isempty(oMal.value_.item(0)) then + set EVAL = env.env.item(eval_ast(oMal.value_.item(0),env).value_)(eval_ast(oMal,env)) + 'else + 'end if + end if + case else + set EVAL = eval_ast(oMal,env) + end select +End Function + +function eval_ast(ast,env) + select case ast.type_ + case "list()" + for i = 0 to ast.value_.count - 1 + set ast.value_.item(i) = EVAL(ast.value_.item(i),env) + next + set eval_ast = ast + case "symbol" + if env.env.Exists(ast.value_) then + set eval_ast = ast + else + 'err.raise vbObjectError, "eval_ast", "undefined symbol: " & ast.value_ + wsh.echo "undefined symbol: " & ast.value_ + ast.value_ = "donothing" + set eval_ast = ast + end if + case "list[]" + for i = 0 to ast.value_.count - 1 + set ast.value_.item(i) = EVAL(ast.value_.item(i),env) + next + set eval_ast = ast + case "hash-map" + For i = 0 To ast.value_.Count -1 ' 迭代数组。 + ' wsh.echo ast.value_.keys()(i).value_ + ' wsh.echo ast.value_.item(ast.value_.keys()(i)).value_ + set ast.value_.item(ast.value_.keys()(i)) = EVAL(ast.value_.item(ast.value_.keys()(i)),env) + Next + set eval_ast = ast + case else + set eval_ast = ast + end select +end function + + +Function PRINT(oMal) + PRINT = pr_str(oMal,true) +End Function + +Function rep(str,env) + 'on error resume next + rep = PRINT(EVAL(READ(str),env)) + 'msgbox 2 + if err.number <> 0 then rep = err.description + on error goto 0 +End Function + +While True + WScript.StdOut.Write("user> ") + code = WScript.StdIn.ReadLine() + set env = new enviroment + WScript.Echo(rep(code,env)) +WEnd + +Sub Include(sInstFile) + Dim oFSO, f, s + Set oFSO = CreateObject("Scripting.FileSystemObject") + sInstFile = oFSO.GetParentFolderName(oFSO.GetFile(Wscript.ScriptFullName)) & "\" & sInstFile + Set f = oFSO.OpenTextFile(sInstFile) + s = f.ReadAll + f.Close + Set f = Nothing + Set oFSO = Nothing + ExecuteGlobal s +End Sub \ No newline at end of file From aa4e5492a6fffa78bebd523dab066ff5e4c62149 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sat, 27 Aug 2022 22:05:13 +0800 Subject: [PATCH 07/44] rewrite code1 --- impls/vbs/printer.vbs | 2 +- impls/vbs/reader.vbs | 190 +++++++++++++++++++-------------- impls/vbs/step0_repl.vbs | 30 +++--- impls/vbs/step1_read_print.vbs | 50 ++++----- impls/vbs/step2_eval.vbs | 7 +- 5 files changed, 160 insertions(+), 119 deletions(-) diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs index d0a818df..9851496e 100644 --- a/impls/vbs/printer.vbs +++ b/impls/vbs/printer.vbs @@ -1,5 +1,5 @@ Function pr_str(o,print_readably) - msgbox typename(o) = "Nothing" + 'msgbox typename(o) = "Nothing" if typename(o) = "Nothing" then pr_str = "" exit function diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index 71173a6d..bb779ae5 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -1,35 +1,33 @@ Include "printer.vbs" Class MalType - Public Type_ - Public value_ + Public Type + Public Value End Class - -'msgbox pr_str(read_str("(123 (456, 567))")) -'msgbox typename(CreateObject("System.Collections.ArrayList")) -'msgbox pr_str(read_str("(123 ")) -Function read_str(str) - set read_str=read_form(tokenize(str)) - 'msgbox pr_str(read_str,true) +Function ReadString(strCode) + Set ReadString = ReadForm(Tokenize(strCode)) End Function -Function tokenize(str) - Set oQueue = CreateObject("System.Collections.Queue") - Set regEx = New RegExp - regEx.Pattern = "[\s,]*(~@|[\[\]{}()'`~^@]|""(?:\\.|[^\\""])*""?|;.*|[^\s\[\]{}('""`,;)]*)" - regEx.IgnoreCase = True - regEx.Global = True - Set Matches = regEx.Execute(str) - For Each Match In Matches - 'msgbox Match.SubMatches(0) - if not left(Match.SubMatches(0), 1) = ";" then - oQueue.Enqueue(Match.SubMatches(0)) - End if +Function Tokenize(strCode) + Set objRE = New RegExp + With objRE + .Pattern = "[\s,]*(~@|[\[\]{}()'`~^@]|""(?:\\.|[^\\""])*""?|;.*|[^\s\[\]{}('""`,;)]*)" + .IgnoreCase = True + .Global = True + End With + + Set objTokens = CreateObject("System.Collections.Queue") + Set objMatches = objRE.Execute(strCode) + Dim strToken + For Each objMatch In objMatches + strToken = Match.SubMatches(0) + If Not Left(strToken, 1) = ";" Then + objTokens.Enqueue strToken + End If Next - Set regEx = Nothing - Set Matches = Nothing - Set tokenize = oQueue + + Set Tokenize = objTokens End Function Function read_form_(oQueue) @@ -40,21 +38,26 @@ Function read_form_(oQueue) end if End Function -Function read_form(oQueue) - if oQueue.Count = 0 then - Set read_form = Nothing - exit function - end if - If oQueue.Peek() = "(" or oQueue.Peek() = "[" or oQueue.Peek() = "{" Then - if oQueue.Peek() = "(" then - Set read_form = read_list(oQueue) - elseif oQueue.Peek() = "[" then - Set read_form = read_vector(oQueue) - elseif oQueue.Peek() = "{" then - Set read_form = read_hash_map(oQueue) - end if - elseif oQueue.Peek() = "'" or oQueue.Peek() = "`" or oQueue.Peek() = "~" or oQueue.Peek() = "~@" or oQueue.Peek = "@" then - select case oQueue.Dequeue() +Function ReadForm(objTokens) + If objTokens.Count = 0 Then + Set ReadForm = Nothing + Exit Function + End If + + Dim strToken + strToken = objTokens.Peek() + + If InStr("([{", strToken) Then + Select Case strToken + Case "(" + Set ReadForm = ReadList(oQueue) + Case "[" + Set ReadForm = ReadVector(oQueue) + Case "{" + Set ReadForm = ReadHashmap(oQueue) + End Select + ElseIf InStr("'`~@", strToken) Then + Select Case strToken case "'" s = "quote" case "`" @@ -97,52 +100,83 @@ Function read_form(oQueue) End Function -Function read_list(oQueue) - p = oQueue.Dequeue() - if p = "(" Then - q = ")" - elseif p = "[" then - q = "]" - elseif p = "{" then - q = "}" - end if - - set read_list = new MalType - set read_list.value_ = CreateObject("System.Collections.ArrayList") - read_list.type_ = "list"+p+q - - While oQueue.count > 1 And oQueue.Peek() <> q - read_list.value_.Add read_form(oQueue) - Wend - If oQueue.Dequeue() <> q Then - err.raise vbObjectError,"reader", "excepted '"+q+"', got EOF" +Function ReadList(objTokens) + Call objTokens.Dequeue() + + If objTokens.Count = 0 Then + 'TODO End If - 'msgbox oQueue.peek -End Function + + Set ReadList = New MalType + Set ReadList.Value = CreateObject("System.Collections.ArrayList") + ReadList.Type = "List" -function read_vector(oQueue) - set read_vector = read_list(oQueue) -end function - -function read_hash_map(oQueue) - oQueue.Dequeue() - set read_hash_map = new MalType - set read_hash_map.value_ = CreateObject("Scripting.Dictionary") - - read_hash_map.type_ = "hash-map" - While oQueue.count > 1 And oQueue.Peek() <> "}" - set key = read_form(oQueue) - read_hash_map.value_.Add key, read_form(oQueue) - Wend - If oQueue.Dequeue() <> "}" Then - err.raise vbObjectError,"reader", "excepted '}', got EOF" + With ReadList.Value + While objTokens.Count > 1 And objTokens.Peek() <> ")" + .Add ReadForm(objTokens) + Wend + End With + + If objTokens.Dequeue() <> ")" Then + 'TODO + 'Err.raise vbObjectError,"reader", "excepted '"+q+"', got EOF" End If End Function +function ReadVector(objTokens) + Call objTokens.Dequeue() + + If objTokens.Count = 0 Then + 'TODO + End If + + Set ReadVector = New MalType + Set ReadVector.Value = CreateObject("System.Collections.ArrayList") + ReadVector.Type = "Vector" + + With ReadVector.Value + While objTokens.Count > 1 And objTokens.Peek() <> "]" + .Add ReadForm(objTokens) + Wend + End With + + If objTokens.Dequeue() <> "]" Then + 'TODO + 'err.raise vbObjectError,"reader", "excepted '"+q+"', got EOF" + End If +End Function +Function ReadHashmap(objTokens) + Call objTokens.Dequeue() + + If objTokens.Count < 2 Then + 'TODO + End If + + Set ReadHashmap = New MalType + Set ReadHashmap.Value = CreateObject("Scripting.Dictionary") + ReadHashmap.Type = "Hashmap" + + Dim objKey, objValue + With ReadHashmap.Value + While objTokens.Count > 2 And objTokens.Peek() <> "}" + Set objKey = ReadForm(oQueue) + Set objValue = ReadForm(oQueue) + .Add objKey, objValue + Wend + End With + + If objTokens.Dequeue() <> "}" Then + 'TODO + 'err.raise vbObjectError,"reader", "excepted '}', got EOF" + End If +End Function -Function read_atom(oQueue) - atom = oQueue.Dequeue() +Function ReadAtom(objTokens) + Dim strAtom + strAtom = objTokens.Dequeue() + + 'TODO if atom = "" then set read_atom = Nothing elseif isnumeric(atom) Then diff --git a/impls/vbs/step0_repl.vbs b/impls/vbs/step0_repl.vbs index 4143b3e3..bc9d6e32 100644 --- a/impls/vbs/step0_repl.vbs +++ b/impls/vbs/step0_repl.vbs @@ -1,21 +1,27 @@ -Function READ(str) - READ = str +Option Explicit + +Function Read(strCode) + Read = strCode End Function -Function EVAL(str) - EVAL = str +Function Evaluate(strCode) + Evaluate = strCode End Function -Function PRINT(str) - PRINT = str +Function Print(strCode) + Print = strCode End Function -Function rep(str) - rep = PRINT(EVAL(READ(str))) +Function REP(strCode) + REP = Print(Evaluate(Read(strCode))) End Function -While True - WScript.StdOut.Write("user> ") - code = WScript.StdIn.ReadLine() - WScript.Echo(rep(code)) +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 diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs index 00fb020e..4f8fda92 100644 --- a/impls/vbs/step1_read_print.vbs +++ b/impls/vbs/step1_read_print.vbs @@ -1,39 +1,39 @@ Include "reader.vbs" Include "printer.vbs" -Function READ(str) - set READ = read_str(str) +Option Explicit + +Function Read(strCode) + Read = strCode End Function -Function EVAL(oMal) - set EVAL = oMal +Function Evaluate(strCode) + Evaluate = strCode End Function -Function PRINT(oMal) - PRINT = pr_str(oMal,true) +Function Print(strCode) + Print = strCode End Function -Function rep(str) - on error resume next - rep = PRINT(EVAL(READ(str))) - if err.number <> 0 then rep = err.description - on error goto 0 +Function REP(strCode) + REP = Print(Evaluate(Read(strCode))) End Function -While True - WScript.StdOut.Write("user> ") - code = WScript.StdIn.ReadLine() - WScript.Echo(rep(code)) +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 -Sub Include(sInstFile) - Dim oFSO, f, s - Set oFSO = CreateObject("Scripting.FileSystemObject") - sInstFile = oFSO.GetParentFolderName(oFSO.GetFile(Wscript.ScriptFullName)) & "\" & sInstFile - Set f = oFSO.OpenTextFile(sInstFile) - s = f.ReadAll - f.Close - Set f = Nothing - Set oFSO = Nothing - ExecuteGlobal s +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With End Sub \ No newline at end of file diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs index a50ad4c4..7977aad6 100644 --- a/impls/vbs/step2_eval.vbs +++ b/impls/vbs/step2_eval.vbs @@ -29,7 +29,7 @@ end function function donothing(args) set donothing = new MalType donothing.type_ = "nil" - donothing.value_ = "error" + donothing.value_ = "" end function class enviroment @@ -50,8 +50,9 @@ Function READ(str) End Function Function EVAL(oMal,env) - 'msgbox typename(o) - if isempty(o) then + 'msgbox typename(oMal) + if TypeName(oMal) = "Nothing" then + 'msgbox "nothing" set EVAL = donothing("") exit function end if From 338ec768fc930d1399505c428ce8f26701a2cd5e Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sun, 28 Aug 2022 00:00:10 +0800 Subject: [PATCH 08/44] rewrite code 2 --- impls/vbs/const.vbs | 14 +++ impls/vbs/env.vbs | 32 ++++++ impls/vbs/printer.vbs | 122 ++++++++++++-------- impls/vbs/reader.vbs | 247 ++++++++++++++++++++-------------------- impls/vbs/step3_env.vbs | 130 +++++++++++++++++++++ 5 files changed, 375 insertions(+), 170 deletions(-) create mode 100644 impls/vbs/const.vbs create mode 100644 impls/vbs/env.vbs create mode 100644 impls/vbs/step3_env.vbs diff --git a/impls/vbs/const.vbs b/impls/vbs/const.vbs new file mode 100644 index 00000000..4790c4d2 --- /dev/null +++ b/impls/vbs/const.vbs @@ -0,0 +1,14 @@ +Const TYPE_LIST = 0 +Const TYPE_VECTOR = 1 +Const TYPE_HASHMAP = 2 +Const TYPE_BOOLEAN = 3 +Const TYPE_NIL = 4 +Const TYPE_KEYWORD = 5 +Const TYPE_STRING = 6 +Const TYPE_NUMBER = 7 +Const TYPE_SYMBOL = 8 + +Class MalType + Public [Type] + Public Value +End Class diff --git a/impls/vbs/env.vbs b/impls/vbs/env.vbs new file mode 100644 index 00000000..7586079e --- /dev/null +++ b/impls/vbs/env.vbs @@ -0,0 +1,32 @@ + +class enviroment + public data + private sub Class_Initialize() + set data = CreateObject("Scripting.Dictionary") + + end sub + + public sub setOuter(outer) + data.add "outer", outer + end sub + + public sub set_(symbolKey,malValue) + data.add symbolKey, malValue + end sub + + public function find(symbolKey) + if data.Exists(symbolKey) then + set find = data + else + if data.item("outer") = empty then + err.raise vbObjectError, "find", "not found, undefined symbol: " & symbolKey + else + set find = data.item("outer").find(symbolKey) + end if + end if + end function + + public function get_(symbolKey) + set get_ = find(symbolKey).item(symbolKey) + end function +end class \ No newline at end of file diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs index 9851496e..57247a6b 100644 --- a/impls/vbs/printer.vbs +++ b/impls/vbs/printer.vbs @@ -1,53 +1,79 @@ -Function pr_str(o,print_readably) - 'msgbox typename(o) = "Nothing" - if typename(o) = "Nothing" then - pr_str = "" - exit function - end if - If left(o.type_,4) = "list" Then - pr_str =mid(o.type_,5,1) - bool = False - For Each item In o.value_ - bool = True - pr_str =pr_str & pr_str(item,print_readably) & " " - Next - if bool then - pr_str = left(pr_str,len(pr_str)-1) & mid(o.type_,6,1) - else - pr_str = mid(o.type_,5,2) - End If - elseif o.type_ = "hash-map" Then - pr_str = "{" - bool = False - For each item in o.value_ - bool = True - pr_str =pr_str & pr_str(item,print_readably) & " " & pr_str(o.value_.item(item),print_readably) & " " - Next - if bool then - pr_str = left(pr_str,len(pr_str)-1) & "}" - else - pr_str = "{}" - End If - Else - if print_readably and o.type_="string" then - pr_str = o.value_ - pr_str = replace(pr_str,"\","\\") - pr_str = replace(pr_str,vbnewline,"\n") - pr_str = replace(pr_str,"""","\""") - pr_str = """" & pr_str & """" - Elseif o.type_="string" then - pr_str = """" & o.value_ & """" - else - pr_str = o.value_ - End If +Function PrintMalType(objMal, boolReadable) + PrintMalType = "" + If TypeName(objMal) = "Nothing" Then + Exit Function End If + Select Case objMal.Type + Case TYPE_LIST + With objMal.Value + Dim i + For i = 0 To .Count - 2 + PrintMalType = PrintMalType & _ + PrintMalType(.Item(i), boolReadable) & " " + Next + If .Count > 0 Then + PrintMalType = PrintMalType & _ + PrintMalType(.Item(.Count - 1), boolReadable) + End If + End With + PrintMalType = "(" & PrintMalType & ")" + Case TYPE_VECTOR + With objMal.Value + Dim i + For i = 0 To .Count - 2 + PrintMalType = PrintMalType & _ + PrintMalType(.Item(i), boolReadable) & " " + Next + If .Count > 0 Then + PrintMalType = PrintMalType & _ + PrintMalType(.Item(.Count - 1), boolReadable) + End If + End With + PrintMalType = "[" & PrintMalType & "]" + Case TYPE_HASHMAP + With objMal.Value + Dim arrKeys + arrKeys = .Keys + Dim i + For i = 0 To .Count - 2 + PrintMalType = PrintMalType & _ + PrintMalType(arrKeys(i), boolReadable) & " " & _ + PrintMalType(.Item(arrKeys(i)), boolReadable) & " " + Next + If .Count > 0 Then + PrintMalType = PrintMalType & _ + PrintMalType(arrKeys(.Count - 1), boolReadable) & " " & _ + PrintMalType(.Item(arrKeys(.Count - 1)), boolReadable) + End If + End With + PrintMalType = "{" & PrintMalType & "}" + Case TYPE_STRING + If boolReadable Then + PrintMalType = EscapeString(objMal.Value) + Else + PrintMalType = objMal.Value + End If + Case TYPE_BOOLEAN + If objMal.Value Then + PrintMalType = "true" + Else + PrintMalType = "false" + End If + Case TYPE_NIL + PrintMalType = "nil" + Case TYPE_NUMBER + PrintMalType = CStr(objMal.Value) + Case Else + PrintMalType = objMal.Value + End Select End Function -' set list = CreateObject("System.Collections.ArrayList") -' list.add(3) -' for each i in list -' msgbox i -' next - +Function EscapeString(strRaw) + EscapeString = strRaw + EscapeString = Replace(EscapeString, "\", "\\") + EscapeString = Replace(EscapeString, vbCrLf, "\n") + EscapeString = Replace(EscapeString, """", "\""") + EscapeString = """" & EscapeString & """" +End Function \ No newline at end of file diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index bb779ae5..aad20082 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -1,10 +1,3 @@ -Include "printer.vbs" - -Class MalType - Public Type - Public Value -End Class - Function ReadString(strCode) Set ReadString = ReadForm(Tokenize(strCode)) End Function @@ -30,13 +23,13 @@ Function Tokenize(strCode) Set Tokenize = objTokens End Function -Function read_form_(oQueue) - set read_form_=read_form(oQueue) - 'msgbox pr_str(read_form_),true - if oQueue.Count > 0 then - err.raise vbObjectError,"SyntaxError", "Extra data after form: " + oQueue.Dequeue - end if -End Function +'Function read_form_(oQueue) +' set read_form_=read_form(oQueue) +' 'msgbox pr_str(read_form_),true +' if oQueue.Count > 0 then +' err.raise vbObjectError,"SyntaxError", "Extra data after form: " + oQueue.Dequeue +' end if +'End Function Function ReadForm(objTokens) If objTokens.Count = 0 Then @@ -50,54 +43,55 @@ Function ReadForm(objTokens) If InStr("([{", strToken) Then Select Case strToken Case "(" - Set ReadForm = ReadList(oQueue) + Set ReadForm = ReadList(objTokens) Case "[" - Set ReadForm = ReadVector(oQueue) + Set ReadForm = ReadVector(objTokens) Case "{" - Set ReadForm = ReadHashmap(oQueue) + Set ReadForm = ReadHashmap(objTokens) End Select ElseIf InStr("'`~@", strToken) Then + Dim strAlias Select Case strToken - case "'" - s = "quote" - case "`" - s = "quasiquote" - case "~" - s = "unquote" - case "~@" - s = "splice-unquote" - case "@" - s = "deref" - end select - set o = new MalType - o.Type_ = "symbol" - o.value_ = s - set l = new MalType - l.Type_ = "list()" - set l.value_ = CreateObject("System.Collections.ArrayList") - l.value_.Add(o) - l.value_.Add(read_form(oQueue)) - set read_form = l - elseif oQueue.Peek() = ")" or oQueue.Peek() = "]" or oQueue.Peek() = "}" then - Set read_form = Nothing - err.Raise vbObjectError, "read_form", "unbalanced parentheses" - elseif oQueue.Peek() = "^" then + Case "'" + strAlias = "quote" + Case "`" + strAlias = "quasiquote" + Case "~" + strAlias = "unquote" + Case "~@" + strAlias = "splice-unquote" + Case "@" + strAlias = "deref" + Case Else + 'TODO + End Select + + Set ReadForm = New MalType + ReadForm.Type = TYPE_LIST + Set ReadForm.Value = CreateObject("System.Collections.ArrayList") + ReadForm.Value.Add New MalType + ReadForm.Value.Item(0).Type = TYPE_SYMBOL + ReadForm.Value.Item(0).Value = strAlias + ReadForm.Value.Add ReadForm(objTokens) + 'TODO + 'ElseIf oQueue.Peek() = ")" or oQueue.Peek() = "]" or oQueue.Peek() = "}" then + ' Set read_form = Nothing + ' err.Raise vbObjectError, "read_form", "unbalanced parentheses" + ElseIf strToken = "^" Then oQueue.Dequeue() - set o = new MalType - o.Type_ = "symbol" - o.value_ = "with-meta" - set l = new MalType - l.Type_ = "list()" - set l.value_ = CreateObject("System.Collections.ArrayList") - l.value_.Add(o) - set tmp = read_form(oQueue) - l.value_.Add(read_form(oQueue)) - l.value_.Add(tmp) - set read_form = l + Set ReadForm = New MalType + ReadForm.Type = TYPE_LIST + Set ReadForm.Value = CreateObject("System.Collections.ArrayList") + ReadForm.Value.Add New MalType + ReadForm.Value.Item(0).Type = TYPE_SYMBOL + ReadForm.Value.Item(0).Value = "with-meta" + Dim objTemp + Set objTemp = ReadForm(objTokens) + ReadForm.Value.Add ReadForm(objTokens) + ReadForm.Value.Add objTemp Else - set read_form = read_atom(oQueue) + Set read_form = read_atom(oQueue) End If - End Function Function ReadList(objTokens) @@ -109,7 +103,7 @@ Function ReadList(objTokens) Set ReadList = New MalType Set ReadList.Value = CreateObject("System.Collections.ArrayList") - ReadList.Type = "List" + ReadList.Type = TYPE_LIST With ReadList.Value While objTokens.Count > 1 And objTokens.Peek() <> ")" @@ -132,7 +126,7 @@ function ReadVector(objTokens) Set ReadVector = New MalType Set ReadVector.Value = CreateObject("System.Collections.ArrayList") - ReadVector.Type = "Vector" + ReadVector.Type = TYPE_VECTOR With ReadVector.Value While objTokens.Count > 1 And objTokens.Peek() <> "]" @@ -155,7 +149,7 @@ Function ReadHashmap(objTokens) Set ReadHashmap = New MalType Set ReadHashmap.Value = CreateObject("Scripting.Dictionary") - ReadHashmap.Type = "Hashmap" + ReadHashmap.Type = TYPE_HASHMAP Dim objKey, objValue With ReadHashmap.Value @@ -176,70 +170,79 @@ Function ReadAtom(objTokens) Dim strAtom strAtom = objTokens.Dequeue() - 'TODO - if atom = "" then - set read_atom = Nothing - elseif isnumeric(atom) Then - set read_atom = new MalType - read_atom.Type_ = "number" - read_atom.value_ = cdbl(atom) - 'msgbox "here" - elseif atom = "true" or atom = "false" Then - set read_atom = new MalType - read_atom.Type_ = "boolean" - read_atom.value_ = atom - elseif left(atom,1) = """" Then - if (not right(atom,1) = """") or len(atom) = 1 then err.raise vbObjectError,"reader", "Unterminated string, got EOF" - set read_atom = new MalType - read_atom.Type_ = "string" - str_tmp = "" - for i = 2 to len(atom) - 1 - if backslash then - backslash = False - 'msgbox backslash - if mid(atom,i,1) = "n" then - str_tmp = str_tmp + vbnewline - elseif mid(atom,i,1) = "\" then - str_tmp = str_tmp + "\" - elseif mid(atom,i,1) = """" then - str_tmp = str_tmp + """" - end if - else - if mid(atom,i,1) = "\" then - backslash = True - else - str_tmp = str_tmp + mid(atom,i,1) - end if - end if - next - if backslash then err.raise vbObjectError,"reader", "Unterminated string, got EOF" - read_atom.value_ = str_tmp - elseif atom = "nil" Then - set read_atom = new MalType - read_atom.Type_ = "null" - read_atom.value_ = atom - elseif left(atom,1) = ":" Then - set read_atom = new MalType - read_atom.Type_ = "keyword" - read_atom.value_ = atom - elseif left(atom,1) = ";" Then - set read_atom = nothing - else - set read_atom = new MalType - read_atom.Type_ = "symbol" - read_atom.value_ = atom - End If + Dim objAtom + Set objAtom = New MalType + Select Case strAtom + Case "true" + objAtom.Type = TYPE_BOOLEAN + objAtom.Value = True + Case "false" + objAtom.Type = TYPE_BOOLEAN + objAtom.Value = False + Case "nil" + objAtom.Type = TYPE_NIL + objAtom.Value = Null + Case Else + Select Case Left(strAtom, 1) + Case ":" + objAtom.Type = TYPE_KEYWORD + objAtom.Value = strAtom + Case """" + 'TODO check string + 'if (not right(atom,1) = """") or len(atom) = 1 then err.raise vbObjectError,"reader", "Unterminated string, got EOF" + objAtom.Type = TYPE_STRING + objAtom.Value = ParseString(strAtom) + Case Else + If IsNumeric(strAtom) + objAtom.Type = TYPE_NUMBER + objAtom.Value = Eval(strAtom) + Else + objAtom.Type = TYPE_SYMBOL + objAtom.Value = strAtom + End If + End Select + End Select + + Set ReadAtom = objAtom End Function - -Sub Include(sInstFile) - Dim oFSO, f, s - Set oFSO = CreateObject("Scripting.FileSystemObject") - sInstFile = oFSO.GetParentFolderName(oFSO.GetFile(Wscript.ScriptFullName)) & "\" & sInstFile - Set f = oFSO.OpenTextFile(sInstFile) - s = f.ReadAll - f.Close - Set f = Nothing - Set oFSO = Nothing - ExecuteGlobal s -End Sub \ No newline at end of file +Function ParseString(strRaw) + ParseString = strRaw + 'TODO +' Dim atom +' atom=strAtom +' if atom = "" then +' set read_atom = Nothing +' elseif left(atom,1) = """" Then +' set read_atom = new MalType +' read_atom.Type_ = "string" +' str_tmp = "" +' for i = 2 to len(atom) - 1 +' if backslash then +' backslash = False +' 'msgbox backslash +' if mid(atom,i,1) = "n" then +' str_tmp = str_tmp + vbnewline +' elseif mid(atom,i,1) = "\" then +' str_tmp = str_tmp + "\" +' elseif mid(atom,i,1) = """" then +'' str_tmp = str_tmp + """" +' end if +' else +' if mid(atom,i,1) = "\" then +' backslash = True +' else +' str_tmp = str_tmp + mid(atom,i,1) +' end if +' end if +' next +' if backslash then err.raise vbObjectError,"reader", "Unterminated string, got EOF" +' read_atom.value_ = str_tmp + 'elseif left(atom,1) = ";" Then + ' set read_atom = nothing + 'else + ' set read_atom = new MalType + ' read_atom.Type_ = "symbol" + ' read_atom.value_ = atom + 'End If +End Function diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs new file mode 100644 index 00000000..8eb674c3 --- /dev/null +++ b/impls/vbs/step3_env.vbs @@ -0,0 +1,130 @@ +Include "reader.vbs" +Include "printer.vbs" +Include "env.vbs" + +function add(args) + set add = new MalType + add.type_ = "number" + 'msgbox typename(args) + add.value_ = args.value_.item(1).value_ + args.value_.item(2).value_ +end function + +function subtract(args) + set subtract = new MalType + subtract.type_ = "number" + subtract.value_ = args.value_.item(1).value_ - args.value_.item(2).value_ +end function + +function multiply(args) + set multiply = new MalType + multiply.type_ = "number" + multiply.value_ = args.value_.item(1).value_ * args.value_.item(2).value_ +end function + +function divide(args) + set divide = new MalType + divide.type_ = "number" + divide.value_ = args.value_.item(1).value_ / args.value_.item(2).value_ +end function + +function donothing(args) + set donothing = new MalType + donothing.type_ = "nil" + donothing.value_ = "" +end function + + +Function READ(str) + set READ = read_str(str) +End Function + +Function EVAL(oMal,env) + 'msgbox typename(oMal) + if TypeName(oMal) = "Nothing" then + 'msgbox "nothing" + set EVAL = donothing("") + exit function + end if + select case oMal.type_ + case "list()" + if oMal.value_.count = 0 then + set EVAL = oMal + else + 'wsh.echo oMal.value_.item(0).value_ + 'wsh.echo typename(env.env) + 'msgbox eval_ast(oMal.value_.item(1),env).value_ + 'msgbox typename(env.env.item("+")(oMal)) + 'if not isempty(oMal.value_.item(0)) then + set EVAL = env.env.item(eval_ast(oMal.value_.item(0),env).value_)(eval_ast(oMal,env)) + 'else + 'end if + end if + case else + set EVAL = eval_ast(oMal,env) + end select +End Function + +function eval_ast(ast,env) + select case ast.type_ + case "list()" + for i = 0 to ast.value_.count - 1 + set ast.value_.item(i) = EVAL(ast.value_.item(i),env) + next + set eval_ast = ast + case "symbol" + if env.env.Exists(ast.value_) then + set eval_ast = ast + else + 'err.raise vbObjectError, "eval_ast", "undefined symbol: " & ast.value_ + wsh.echo "undefined symbol: " & ast.value_ + ast.value_ = "donothing" + set eval_ast = ast + end if + case "list[]" + for i = 0 to ast.value_.count - 1 + set ast.value_.item(i) = EVAL(ast.value_.item(i),env) + next + set eval_ast = ast + case "hash-map" + For i = 0 To ast.value_.Count -1 ' 迭代数组。 + ' wsh.echo ast.value_.keys()(i).value_ + ' wsh.echo ast.value_.item(ast.value_.keys()(i)).value_ + set ast.value_.item(ast.value_.keys()(i)) = EVAL(ast.value_.item(ast.value_.keys()(i)),env) + Next + set eval_ast = ast + case else + set eval_ast = ast + end select +end function + + +Function PRINT(oMal) + PRINT = pr_str(oMal,true) +End Function + +Function rep(str,env) + 'on error resume next + rep = PRINT(EVAL(READ(str),env)) + 'msgbox 2 + if err.number <> 0 then rep = err.description + on error goto 0 +End Function + +While True + WScript.StdOut.Write("user> ") + code = WScript.StdIn.ReadLine() + set env = new enviroment + WScript.Echo(rep(code,env)) +WEnd + +Sub Include(sInstFile) + Dim oFSO, f, s + Set oFSO = CreateObject("Scripting.FileSystemObject") + sInstFile = oFSO.GetParentFolderName(oFSO.GetFile(Wscript.ScriptFullName)) & "\" & sInstFile + Set f = oFSO.OpenTextFile(sInstFile) + s = f.ReadAll + f.Close + Set f = Nothing + Set oFSO = Nothing + ExecuteGlobal s +End Sub \ No newline at end of file From 96eb5eec3f7ac7ccb5d3080e4b83d04f98d2bcca Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sun, 28 Aug 2022 00:53:12 +0800 Subject: [PATCH 09/44] rewrite 3 --- impls/vbs/printer.vbs | 7 +-- impls/vbs/reader.vbs | 101 ++++++++++++++++++--------------- impls/vbs/step1_read_print.vbs | 39 ++++++------- 3 files changed, 79 insertions(+), 68 deletions(-) diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs index 57247a6b..acb7947a 100644 --- a/impls/vbs/printer.vbs +++ b/impls/vbs/printer.vbs @@ -1,13 +1,15 @@ +Option Explicit + Function PrintMalType(objMal, boolReadable) PrintMalType = "" If TypeName(objMal) = "Nothing" Then Exit Function End If + Dim i Select Case objMal.Type Case TYPE_LIST With objMal.Value - Dim i For i = 0 To .Count - 2 PrintMalType = PrintMalType & _ PrintMalType(.Item(i), boolReadable) & " " @@ -20,7 +22,6 @@ Function PrintMalType(objMal, boolReadable) PrintMalType = "(" & PrintMalType & ")" Case TYPE_VECTOR With objMal.Value - Dim i For i = 0 To .Count - 2 PrintMalType = PrintMalType & _ PrintMalType(.Item(i), boolReadable) & " " @@ -35,7 +36,6 @@ Function PrintMalType(objMal, boolReadable) With objMal.Value Dim arrKeys arrKeys = .Keys - Dim i For i = 0 To .Count - 2 PrintMalType = PrintMalType & _ PrintMalType(arrKeys(i), boolReadable) & " " & _ @@ -69,7 +69,6 @@ Function PrintMalType(objMal, boolReadable) End Select End Function - Function EscapeString(strRaw) EscapeString = strRaw EscapeString = Replace(EscapeString, "\", "\\") diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index aad20082..a6dd9ef8 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -1,8 +1,11 @@ +Option Explicit + Function ReadString(strCode) Set ReadString = ReadForm(Tokenize(strCode)) End Function Function Tokenize(strCode) + Dim objRE Set objRE = New RegExp With objRE .Pattern = "[\s,]*(~@|[\[\]{}()'`~^@]|""(?:\\.|[^\\""])*""?|;.*|[^\s\[\]{}('""`,;)]*)" @@ -10,16 +13,18 @@ Function Tokenize(strCode) .Global = True End With + Dim objTokens, objMatches, objMatch Set objTokens = CreateObject("System.Collections.Queue") Set objMatches = objRE.Execute(strCode) Dim strToken For Each objMatch In objMatches - strToken = Match.SubMatches(0) + strToken = objMatch.SubMatches(0) If Not Left(strToken, 1) = ";" Then objTokens.Enqueue strToken End If Next - + 'MsgBox objTokens.Count + 'MsgBox """" & objTokens.peek & """" Set Tokenize = objTokens End Function @@ -37,6 +42,12 @@ Function ReadForm(objTokens) Exit Function End If + If objTokens.Count = 1 And objTokens.Peek() = "" Then + Call objTokens.Dequeue() + Set ReadForm = Nothing + Exit Function + End If + Dim strToken strToken = objTokens.Peek() @@ -50,6 +61,8 @@ Function ReadForm(objTokens) Set ReadForm = ReadHashmap(objTokens) End Select ElseIf InStr("'`~@", strToken) Then + Call objTokens.Dequeue() + Dim strAlias Select Case strToken Case "'" @@ -78,7 +91,7 @@ Function ReadForm(objTokens) ' Set read_form = Nothing ' err.Raise vbObjectError, "read_form", "unbalanced parentheses" ElseIf strToken = "^" Then - oQueue.Dequeue() + Call objTokens.Dequeue() Set ReadForm = New MalType ReadForm.Type = TYPE_LIST Set ReadForm.Value = CreateObject("System.Collections.ArrayList") @@ -90,7 +103,7 @@ Function ReadForm(objTokens) ReadForm.Value.Add ReadForm(objTokens) ReadForm.Value.Add objTemp Else - Set read_form = read_atom(oQueue) + Set ReadForm = ReadAtom(objTokens) End If End Function @@ -113,6 +126,7 @@ Function ReadList(objTokens) If objTokens.Dequeue() <> ")" Then 'TODO + MsgBox "e" 'Err.raise vbObjectError,"reader", "excepted '"+q+"', got EOF" End If End Function @@ -136,6 +150,7 @@ function ReadVector(objTokens) If objTokens.Dequeue() <> "]" Then 'TODO + MsgBox "e" 'err.raise vbObjectError,"reader", "excepted '"+q+"', got EOF" End If End Function @@ -154,8 +169,8 @@ Function ReadHashmap(objTokens) Dim objKey, objValue With ReadHashmap.Value While objTokens.Count > 2 And objTokens.Peek() <> "}" - Set objKey = ReadForm(oQueue) - Set objValue = ReadForm(oQueue) + Set objKey = ReadForm(objTokens) + Set objValue = ReadForm(objTokens) .Add objKey, objValue Wend End With @@ -193,7 +208,7 @@ Function ReadAtom(objTokens) objAtom.Type = TYPE_STRING objAtom.Value = ParseString(strAtom) Case Else - If IsNumeric(strAtom) + If IsNumeric(strAtom) Then objAtom.Type = TYPE_NUMBER objAtom.Value = Eval(strAtom) Else @@ -207,42 +222,38 @@ Function ReadAtom(objTokens) End Function Function ParseString(strRaw) - ParseString = strRaw - 'TODO -' Dim atom -' atom=strAtom -' if atom = "" then -' set read_atom = Nothing -' elseif left(atom,1) = """" Then -' set read_atom = new MalType -' read_atom.Type_ = "string" -' str_tmp = "" -' for i = 2 to len(atom) - 1 -' if backslash then -' backslash = False -' 'msgbox backslash -' if mid(atom,i,1) = "n" then -' str_tmp = str_tmp + vbnewline -' elseif mid(atom,i,1) = "\" then -' str_tmp = str_tmp + "\" -' elseif mid(atom,i,1) = """" then -'' str_tmp = str_tmp + """" -' end if -' else -' if mid(atom,i,1) = "\" then -' backslash = True -' else -' str_tmp = str_tmp + mid(atom,i,1) -' end if -' end if -' next -' if backslash then err.raise vbObjectError,"reader", "Unterminated string, got EOF" -' read_atom.value_ = str_tmp - 'elseif left(atom,1) = ";" Then - ' set read_atom = nothing - 'else - ' set read_atom = new MalType - ' read_atom.Type_ = "symbol" - ' read_atom.value_ = atom - 'End If + If Right(strRaw, 1) <> """" Or Len(strRaw) < 2 Then + MsgBox "e" + End If + + Dim strTemp + strTemp = Mid(strRaw, 2, Len(strRaw) - 2) + Dim i + i = 1 + 'Dim strChar + 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 + 'TODO Error + MsgBox "err" + End If + End If End Function diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs index 4f8fda92..4fc2b3aa 100644 --- a/impls/vbs/step1_read_print.vbs +++ b/impls/vbs/step1_read_print.vbs @@ -1,23 +1,8 @@ -Include "reader.vbs" -Include "printer.vbs" - 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 +Include "Const.vbs" +Include "Reader.vbs" +Include "Printer.vbs" Dim strCode While True 'REPL @@ -27,7 +12,23 @@ While True 'REPL If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 WScript.Echo REP(strCode) -WEnd +Wend + +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") From 30720165e80fb1cb476c1881e9216f7173ea051d Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sun, 28 Aug 2022 10:18:52 +0800 Subject: [PATCH 10/44] fix error dealing --- impls/vbs/reader.vbs | 68 ++++++++++++++++++---------------- impls/vbs/step1_read_print.vbs | 26 ++++++++----- 2 files changed, 53 insertions(+), 41 deletions(-) diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index a6dd9ef8..5437a448 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -23,18 +23,11 @@ Function Tokenize(strCode) objTokens.Enqueue strToken End If Next - 'MsgBox objTokens.Count - 'MsgBox """" & objTokens.peek & """" + Set Tokenize = objTokens End Function -'Function read_form_(oQueue) -' set read_form_=read_form(oQueue) -' 'msgbox pr_str(read_form_),true -' if oQueue.Count > 0 then -' err.raise vbObjectError,"SyntaxError", "Extra data after form: " + oQueue.Dequeue -' end if -'End Function +Public boolError, strError Function ReadForm(objTokens) If objTokens.Count = 0 Then @@ -76,7 +69,9 @@ Function ReadForm(objTokens) Case "@" strAlias = "deref" Case Else - 'TODO + boolError = True + strError = "unknown token " & strAlias + Call REPL() End Select Set ReadForm = New MalType @@ -86,10 +81,12 @@ Function ReadForm(objTokens) ReadForm.Value.Item(0).Type = TYPE_SYMBOL ReadForm.Value.Item(0).Value = strAlias ReadForm.Value.Add ReadForm(objTokens) - 'TODO - 'ElseIf oQueue.Peek() = ")" or oQueue.Peek() = "]" or oQueue.Peek() = "}" then - ' Set read_form = Nothing - ' err.Raise vbObjectError, "read_form", "unbalanced parentheses" + ElseIf InStr(")]}", strToken) Then + Call objTokens.Dequeue() + + boolError = True + strError = "unbalanced parentheses" + Call REPL() ElseIf strToken = "^" Then Call objTokens.Dequeue() Set ReadForm = New MalType @@ -111,7 +108,9 @@ Function ReadList(objTokens) Call objTokens.Dequeue() If objTokens.Count = 0 Then - 'TODO + boolError = True + strError = "unbalanced parentheses" + Call REPL() End If Set ReadList = New MalType @@ -125,9 +124,9 @@ Function ReadList(objTokens) End With If objTokens.Dequeue() <> ")" Then - 'TODO - MsgBox "e" - 'Err.raise vbObjectError,"reader", "excepted '"+q+"', got EOF" + boolError = True + strError = "unbalanced parentheses" + Call REPL() End If End Function @@ -135,7 +134,9 @@ function ReadVector(objTokens) Call objTokens.Dequeue() If objTokens.Count = 0 Then - 'TODO + boolError = True + strError = "unbalanced parentheses" + Call REPL() End If Set ReadVector = New MalType @@ -149,17 +150,19 @@ function ReadVector(objTokens) End With If objTokens.Dequeue() <> "]" Then - 'TODO - MsgBox "e" - 'err.raise vbObjectError,"reader", "excepted '"+q+"', got EOF" + boolError = True + strError = "unbalanced parentheses" + Call REPL() End If End Function Function ReadHashmap(objTokens) Call objTokens.Dequeue() - If objTokens.Count < 2 Then - 'TODO + If objTokens.Count = 0 Then + boolError = True + strError = "unbalanced parentheses" + Call REPL() End If Set ReadHashmap = New MalType @@ -176,8 +179,9 @@ Function ReadHashmap(objTokens) End With If objTokens.Dequeue() <> "}" Then - 'TODO - 'err.raise vbObjectError,"reader", "excepted '}', got EOF" + boolError = True + strError = "unbalanced parentheses" + Call REPL() End If End Function @@ -203,8 +207,6 @@ Function ReadAtom(objTokens) objAtom.Type = TYPE_KEYWORD objAtom.Value = strAtom Case """" - 'TODO check string - 'if (not right(atom,1) = """") or len(atom) = 1 then err.raise vbObjectError,"reader", "Unterminated string, got EOF" objAtom.Type = TYPE_STRING objAtom.Value = ParseString(strAtom) Case Else @@ -223,14 +225,15 @@ End Function Function ParseString(strRaw) If Right(strRaw, 1) <> """" Or Len(strRaw) < 2 Then - MsgBox "e" + boolError = True + strError = "Unterminated string, got EOF" + Call REPL() End If Dim strTemp strTemp = Mid(strRaw, 2, Len(strRaw) - 2) Dim i i = 1 - 'Dim strChar ParseString = "" While i <= Len(strTemp) - 1 Select Case Mid(strTemp, i, 2) @@ -252,8 +255,9 @@ Function ParseString(strRaw) If Right(strTemp, 1) <> "\" Then ParseString = ParseString & Right(strTemp, 1) Else - 'TODO Error - MsgBox "err" + boolError = True + strError = "Unterminated string, got EOF" + Call REPL() End If End If End Function diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs index 4fc2b3aa..647522d7 100644 --- a/impls/vbs/step1_read_print.vbs +++ b/impls/vbs/step1_read_print.vbs @@ -4,15 +4,23 @@ Include "Const.vbs" Include "Reader.vbs" Include "Printer.vbs" -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 +Call REPL() + +Sub REPL() + Dim strCode, strResult + While True + If boolError Then + WScript.StdErr.WriteLine "ERROR: " & strError + boolError = False + End If + 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 +End Sub Function Read(strCode) Set Read = ReadString(strCode) From 3dbf38599695c0fcfe7780147b8fb66f556b3339 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sun, 28 Aug 2022 13:44:39 +0800 Subject: [PATCH 11/44] fix step3 --- impls/vbs/env.vbs | 66 ++++---- impls/vbs/reader.vbs | 4 +- impls/vbs/step2_eval.vbs | 251 ++++++++++++++++--------------- impls/vbs/step3_env.vbs | 315 +++++++++++++++++++++++++-------------- 4 files changed, 365 insertions(+), 271 deletions(-) diff --git a/impls/vbs/env.vbs b/impls/vbs/env.vbs index 7586079e..f4352352 100644 --- a/impls/vbs/env.vbs +++ b/impls/vbs/env.vbs @@ -1,32 +1,42 @@ -class enviroment - public data - private sub Class_Initialize() - set data = CreateObject("Scripting.Dictionary") - - end sub +class Environment + Private objOuterEnv + Public objBindings + Private objSelf + Private Sub Class_Initialize() + Set objBindings = CreateObject("Scripting.Dictionary") + Set objOuterEnv = Nothing + Set objSelf = Nothing + End Sub + + Public Function SetOuter(objEnv) + Set objOuterEnv = objEnv + End Function + + Public Function SetSelf(objEnv) + Set objSelf = objEnv + End Function - public sub setOuter(outer) - data.add "outer", outer - end sub + Public Sub Add(varKey, varValue) + 'objBindings.Add varKey, varValue + Set objBindings(varKey) = varValue + End Sub - public sub set_(symbolKey,malValue) - data.add symbolKey, malValue - end sub - - public function find(symbolKey) - if data.Exists(symbolKey) then - set find = data - else - if data.item("outer") = empty then - err.raise vbObjectError, "find", "not found, undefined symbol: " & symbolKey - else - set find = data.item("outer").find(symbolKey) - end if - end if - end function - - public function get_(symbolKey) - set get_ = find(symbolKey).item(symbolKey) - end function + Public Function Find(varKey) + If objBindings.Exists(varKey) Then + Set Find = objSelf + Else + If TypeName(objOuterEnv) <> "Nothing" Then + Set Find = objOuterEnv.Find(varKey) + Else + boolError = True + strError = "symbol " & varKey & " not found" + Call REPL() + End If + End If + End Function + + Public Function [Get](varKey) + Set [Get] = Find(varKey).objBindings(varKey) + End Function end class \ No newline at end of file diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index 5437a448..3dc1cb62 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -226,7 +226,7 @@ End Function Function ParseString(strRaw) If Right(strRaw, 1) <> """" Or Len(strRaw) < 2 Then boolError = True - strError = "Unterminated string, got EOF" + strError = "unterminated string, got EOF" Call REPL() End If @@ -256,7 +256,7 @@ Function ParseString(strRaw) ParseString = ParseString & Right(strTemp, 1) Else boolError = True - strError = "Unterminated string, got EOF" + strError = "unterminated string, got EOF" Call REPL() End If End If diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs index 7977aad6..58c145ee 100644 --- a/impls/vbs/step2_eval.vbs +++ b/impls/vbs/step2_eval.vbs @@ -1,141 +1,140 @@ -Include "reader.vbs" -Include "printer.vbs" +Option Explicit -function add(args) - set add = new MalType - add.type_ = "number" - 'msgbox typename(args) - add.value_ = args.value_.item(1).value_ + args.value_.item(2).value_ -end function +Include "Const.vbs" +Include "Reader.vbs" +Include "Printer.vbs" -function subtract(args) - set subtract = new MalType - subtract.type_ = "number" - subtract.value_ = args.value_.item(1).value_ - args.value_.item(2).value_ -end function +Dim objEnv +Set objEnv = CreateObject("Scripting.Dictionary") +objEnv.Add "+", GetRef("Add") +objEnv.Add "-", GetRef("Subtract") +objEnv.Add "*", GetRef("Multiply") +objEnv.Add "/", GetRef("Divide") -function multiply(args) - set multiply = new MalType - multiply.type_ = "number" - multiply.value_ = args.value_.item(1).value_ * args.value_.item(2).value_ -end function +Sub CheckArgNum(objArgs, lngExpect) + If objArgs.Value.Count - 1 <> 2 Then + boolError = True + strError = "wrong number of arguments" + Call REPL() + End If +End Sub -function divide(args) - set divide = new MalType - divide.type_ = "number" - divide.value_ = args.value_.item(1).value_ / args.value_.item(2).value_ -end function - -function donothing(args) - set donothing = new MalType - donothing.type_ = "nil" - donothing.value_ = "" -end function - -class enviroment - public env - private sub Class_Initialize() - set env = CreateObject("Scripting.Dictionary") - env.add "+",getref("add") - env.add "-",getref("subtract") - env.add "*",getref("multiply") - env.add "/",getref("divide") - env.add "donothing", getref("donothing") - end sub - -end class - -Function READ(str) - set READ = read_str(str) +Function Add(objArgs) + CheckArgNum objArgs, 2 + Set Add = New MalType + Add.Type = TYPE_NUMBER + Add.Value = objArgs.Value.Item(1).Value + objArgs.Value.Item(2).Value End Function -Function EVAL(oMal,env) - 'msgbox typename(oMal) - if TypeName(oMal) = "Nothing" then - 'msgbox "nothing" - set EVAL = donothing("") - exit function - end if - select case oMal.type_ - case "list()" - if oMal.value_.count = 0 then - set EVAL = oMal - else - 'wsh.echo oMal.value_.item(0).value_ - 'wsh.echo typename(env.env) - 'msgbox eval_ast(oMal.value_.item(1),env).value_ - 'msgbox typename(env.env.item("+")(oMal)) - 'if not isempty(oMal.value_.item(0)) then - set EVAL = env.env.item(eval_ast(oMal.value_.item(0),env).value_)(eval_ast(oMal,env)) - 'else - 'end if - end if - case else - set EVAL = eval_ast(oMal,env) - end select +Function Subtract(objArgs) + CheckArgNum objArgs, 2 + Set Subtract = New MalType + Subtract.Type = TYPE_NUMBER + Subtract.Value = objArgs.Value.Item(1).Value - objArgs.Value.Item(2).Value End Function -function eval_ast(ast,env) - select case ast.type_ - case "list()" - for i = 0 to ast.value_.count - 1 - set ast.value_.item(i) = EVAL(ast.value_.item(i),env) - next - set eval_ast = ast - case "symbol" - if env.env.Exists(ast.value_) then - set eval_ast = ast - else - 'err.raise vbObjectError, "eval_ast", "undefined symbol: " & ast.value_ - wsh.echo "undefined symbol: " & ast.value_ - ast.value_ = "donothing" - set eval_ast = ast - end if - case "list[]" - for i = 0 to ast.value_.count - 1 - set ast.value_.item(i) = EVAL(ast.value_.item(i),env) - next - set eval_ast = ast - case "hash-map" - For i = 0 To ast.value_.Count -1 ' 迭代数组。 - ' wsh.echo ast.value_.keys()(i).value_ - ' wsh.echo ast.value_.item(ast.value_.keys()(i)).value_ - set ast.value_.item(ast.value_.keys()(i)) = EVAL(ast.value_.item(ast.value_.keys()(i)),env) +Function Multiply(objArgs) + CheckArgNum objArgs, 2 + Set Multiply = New MalType + Multiply.Type = TYPE_NUMBER + Multiply.Value = objArgs.Value.Item(1).Value * objArgs.Value.Item(2).Value +End Function + +Function Divide(objArgs) + CheckArgNum objArgs, 2 + Set Divide = New MalType + Divide.Type = TYPE_NUMBER + Divide.Value = objArgs.Value.Item(1).Value / objArgs.Value.Item(2).Value +End Function + + +Call REPL() +Sub REPL() + Dim strCode, strResult + While True + If boolError Then + WScript.StdErr.WriteLine "ERROR: " & strError + boolError = False + End If + 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 +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(objCode, objEnv) + If TypeName(objCode) = "Nothing" Then + Call REPL() + End If + + If objCode.Type = TYPE_LIST Then + If objCode.Value.Count = 0 Then + Set Evaluate = objCode + Exit Function + End If + + Set Evaluate = EvaluateAST(objCode, objEnv) + Set Evaluate = Evaluate.Value.Item(0)(Evaluate) + Else + Set Evaluate = EvaluateAST(objCode, objEnv) + End If +End Function + +Function EvaluateAST(objCode, objEnv) + Dim objResult, i + Select Case objCode.Type + Case TYPE_SYMBOL + If objEnv.Exists(objCode.Value) Then + Set objResult = objEnv(objCode.Value) + Else + boolError = True + strError = "symbol not found" + Call REPL() + End If + Case TYPE_LIST + For i = 0 To objCode.Value.Count - 1 + Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) Next - set eval_ast = ast - case else - set eval_ast = ast - end select -end function - - -Function PRINT(oMal) - PRINT = pr_str(oMal,true) + Set objResult = objCode + Case TYPE_VECTOR + For i = 0 To objCode.Value.Count - 1 + Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) + Next + Set objResult = objCode + Case TYPE_HASHMAP + Dim arrKeys + arrKeys = objCode.Value.Keys + For i = 0 To objCode.Value.Count - 1 + Set objCode.Value.Item(arrKeys(i)) = _ + Evaluate(objCode.Value.Item(arrKeys(i)), objEnv) + Next + Set objResult = objCode + Case Else + Set objResult = objCode + End Select + Set EvaluateAST = objResult End Function -Function rep(str,env) - 'on error resume next - rep = PRINT(EVAL(READ(str),env)) - 'msgbox 2 - if err.number <> 0 then rep = err.description - on error goto 0 +Function Print(objCode) + Print = PrintMalType(objCode, True) End Function -While True - WScript.StdOut.Write("user> ") - code = WScript.StdIn.ReadLine() - set env = new enviroment - WScript.Echo(rep(code,env)) -WEnd +Function REP(strCode) + REP = Print(Evaluate(Read(strCode), objEnv)) +End Function -Sub Include(sInstFile) - Dim oFSO, f, s - Set oFSO = CreateObject("Scripting.FileSystemObject") - sInstFile = oFSO.GetParentFolderName(oFSO.GetFile(Wscript.ScriptFullName)) & "\" & sInstFile - Set f = oFSO.OpenTextFile(sInstFile) - s = f.ReadAll - f.Close - Set f = Nothing - Set oFSO = Nothing - ExecuteGlobal s +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With End Sub \ No newline at end of file diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs index 8eb674c3..e125c0f6 100644 --- a/impls/vbs/step3_env.vbs +++ b/impls/vbs/step3_env.vbs @@ -1,130 +1,215 @@ -Include "reader.vbs" -Include "printer.vbs" -Include "env.vbs" +Option Explicit -function add(args) - set add = new MalType - add.type_ = "number" - 'msgbox typename(args) - add.value_ = args.value_.item(1).value_ + args.value_.item(2).value_ -end function +Include "Const.vbs" +Include "Reader.vbs" +Include "Printer.vbs" +Include "Env.vbs" -function subtract(args) - set subtract = new MalType - subtract.type_ = "number" - subtract.value_ = args.value_.item(1).value_ - args.value_.item(2).value_ -end function - -function multiply(args) - set multiply = new MalType - multiply.type_ = "number" - multiply.value_ = args.value_.item(1).value_ * args.value_.item(2).value_ -end function - -function divide(args) - set divide = new MalType - divide.type_ = "number" - divide.value_ = args.value_.item(1).value_ / args.value_.item(2).value_ -end function - -function donothing(args) - set donothing = new MalType - donothing.type_ = "nil" - donothing.value_ = "" -end function +Dim objEnv +Set objEnv = New Environment +objEnv.SetSelf objEnv +objEnv.SetOuter Nothing +objEnv.Add "+", GetRef("Add") +objEnv.Add "-", GetRef("Subtract") +objEnv.Add "*", GetRef("Multiply") +objEnv.Add "/", GetRef("Divide") +objEnv.Add "def!", GetRef("Divide") +objEnv.Add "let*", GetRef("Divide") -Function READ(str) - set READ = read_str(str) +Sub CheckArgNum(objArgs, lngExpect) + If objArgs.Value.Count - 1 <> 2 Then + boolError = True + strError = "wrong number of arguments" + Call REPL() + End If +End Sub + +Function Add(objArgs) + CheckArgNum objArgs, 2 + Set Add = New MalType + Add.Type = TYPE_NUMBER + Add.Value = objArgs.Value.Item(1).Value + objArgs.Value.Item(2).Value End Function -Function EVAL(oMal,env) - 'msgbox typename(oMal) - if TypeName(oMal) = "Nothing" then - 'msgbox "nothing" - set EVAL = donothing("") - exit function - end if - select case oMal.type_ - case "list()" - if oMal.value_.count = 0 then - set EVAL = oMal - else - 'wsh.echo oMal.value_.item(0).value_ - 'wsh.echo typename(env.env) - 'msgbox eval_ast(oMal.value_.item(1),env).value_ - 'msgbox typename(env.env.item("+")(oMal)) - 'if not isempty(oMal.value_.item(0)) then - set EVAL = env.env.item(eval_ast(oMal.value_.item(0),env).value_)(eval_ast(oMal,env)) - 'else - 'end if - end if - case else - set EVAL = eval_ast(oMal,env) - end select +Function Subtract(objArgs) + CheckArgNum objArgs, 2 + Set Subtract = New MalType + Subtract.Type = TYPE_NUMBER + Subtract.Value = objArgs.Value.Item(1).Value - objArgs.Value.Item(2).Value End Function -function eval_ast(ast,env) - select case ast.type_ - case "list()" - for i = 0 to ast.value_.count - 1 - set ast.value_.item(i) = EVAL(ast.value_.item(i),env) - next - set eval_ast = ast - case "symbol" - if env.env.Exists(ast.value_) then - set eval_ast = ast - else - 'err.raise vbObjectError, "eval_ast", "undefined symbol: " & ast.value_ - wsh.echo "undefined symbol: " & ast.value_ - ast.value_ = "donothing" - set eval_ast = ast - end if - case "list[]" - for i = 0 to ast.value_.count - 1 - set ast.value_.item(i) = EVAL(ast.value_.item(i),env) - next - set eval_ast = ast - case "hash-map" - For i = 0 To ast.value_.Count -1 ' 迭代数组。 - ' wsh.echo ast.value_.keys()(i).value_ - ' wsh.echo ast.value_.item(ast.value_.keys()(i)).value_ - set ast.value_.item(ast.value_.keys()(i)) = EVAL(ast.value_.item(ast.value_.keys()(i)),env) +Function Multiply(objArgs) + CheckArgNum objArgs, 2 + Set Multiply = New MalType + Multiply.Type = TYPE_NUMBER + Multiply.Value = objArgs.Value.Item(1).Value * objArgs.Value.Item(2).Value +End Function + +Function Divide(objArgs) + CheckArgNum objArgs, 2 + Set Divide = New MalType + Divide.Type = TYPE_NUMBER + Divide.Value = objArgs.Value.Item(1).Value / objArgs.Value.Item(2).Value +End Function + + +Call REPL() +Sub REPL() + Dim strCode, strResult + While True + If boolError Then + WScript.StdErr.WriteLine "ERROR: " & strError + boolError = False + End If + 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 +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(objCode, objEnv) + Dim i + If TypeName(objCode) = "Nothing" Then + Call REPL() + End If + + If objCode.Type = TYPE_LIST Then + If objCode.Value.Count = 0 Then + Set Evaluate = objCode + Exit Function + End If + + Dim objSymbol + Set objSymbol = Evaluate(objCode.Value.Item(0), objEnv) + If TypeName(objSymbol) = "MalType" Then + 'MsgBox TypeName(objCode.value) + Select Case objSymbol.Value + Case "def!" + CheckArgNum objCode, 2 + CheckSymbol objCode.Value.Item(1) + 'MsgBox 2 + objEnv.Add objCode.Value.Item(1).Value, _ + Evaluate(objCode.Value.Item(2), objEnv) + 'MsgBox 3 + Set Evaluate = objEnv.Get(objCode.Value.Item(1).Value) + Case "let*" + Dim objNewEnv + Set objNewEnv = New Environment + objNewEnv.SetSelf objNewEnv + objNewEnv.SetOuter objEnv + CheckArgNum objCode, 2 + CheckListOrVector objCode.Value.Item(1) + CheckEven objCode.Value.Item(1).Value.Count + With objCode.Value.Item(1).Value + For i = 0 To .Count - 1 Step 2 + CheckSymbol .Item(i) + objNewEnv.Add .Item(i).Value, _ + Evaluate(.Item(i + 1), objNewEnv) + Next + End With + Set Evaluate = Evaluate(objCode.Value.Item(2), objNewEnv) + End Select + Else + Set Evaluate = objSymbol(EvaluateAST(objCode, objEnv)) + End If + Else + Set Evaluate = EvaluateAST(objCode, objEnv) + End If +End Function + +Sub CheckEven(lngNum) + If lngNum Mod 2 <> 0 Then + boolError = True + strError = "not a even number" + Call REPL() + End If +End Sub + +Sub CheckList(objMal) + If objMal.Type <> TYPE_LIST Then + boolError = True + strError = "neither a list nor a vector" + Call REPL() + End If +End Sub + +Sub CheckListOrVector(objMal) + If objMal.Type <> TYPE_LIST And objMal.Type <> TYPE_VECTOR Then + boolError = True + strError = "not a list" + Call REPL() + End If +End Sub + +Sub CheckSymbol(objMal) + If objMal.Type <> TYPE_SYMBOL Then + boolError = True + strError = "not a symbol" + Call REPL() + End If +End Sub + +Function EvaluateAST(objCode, objEnv) + If TypeName(objCode) = "Nothing" Then + MsgBox "Nothing2" + End If + + Dim objResult, i + Select Case objCode.Type + Case TYPE_SYMBOL + Select Case objCode.Value + Case "def!" + Set objResult = objCode + Case "let*" + Set objResult = objCode + Case Else + Set objResult = objEnv.Get(objCode.Value) + End Select + Case TYPE_LIST + For i = 0 To objCode.Value.Count - 1 + Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) Next - set eval_ast = ast - case else - set eval_ast = ast - end select -end function - - -Function PRINT(oMal) - PRINT = pr_str(oMal,true) + Set objResult = objCode + Case TYPE_VECTOR + For i = 0 To objCode.Value.Count - 1 + Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) + Next + Set objResult = objCode + Case TYPE_HASHMAP + Dim arrKeys + arrKeys = objCode.Value.Keys + For i = 0 To objCode.Value.Count - 1 + Set objCode.Value.Item(arrKeys(i)) = _ + Evaluate(objCode.Value.Item(arrKeys(i)), objEnv) + Next + Set objResult = objCode + Case Else + Set objResult = objCode + End Select + Set EvaluateAST = objResult End Function -Function rep(str,env) - 'on error resume next - rep = PRINT(EVAL(READ(str),env)) - 'msgbox 2 - if err.number <> 0 then rep = err.description - on error goto 0 +Function Print(objCode) + Print = PrintMalType(objCode, True) End Function -While True - WScript.StdOut.Write("user> ") - code = WScript.StdIn.ReadLine() - set env = new enviroment - WScript.Echo(rep(code,env)) -WEnd +Function REP(strCode) + REP = Print(Evaluate(Read(strCode), objEnv)) +End Function -Sub Include(sInstFile) - Dim oFSO, f, s - Set oFSO = CreateObject("Scripting.FileSystemObject") - sInstFile = oFSO.GetParentFolderName(oFSO.GetFile(Wscript.ScriptFullName)) & "\" & sInstFile - Set f = oFSO.OpenTextFile(sInstFile) - s = f.ReadAll - f.Close - Set f = Nothing - Set oFSO = Nothing - ExecuteGlobal s +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With End Sub \ No newline at end of file From 7826e767441b8689517cdd28388ca9c3ad89ae95 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sun, 28 Aug 2022 15:46:30 +0800 Subject: [PATCH 12/44] step4 init: --- impls/vbs/const.vbs | 3 +++ impls/vbs/env.vbs | 14 ++++++++++++++ impls/vbs/printer.vbs | 3 +++ impls/vbs/step3_env.vbs | 2 -- 4 files changed, 20 insertions(+), 2 deletions(-) diff --git a/impls/vbs/const.vbs b/impls/vbs/const.vbs index 4790c4d2..7db34a14 100644 --- a/impls/vbs/const.vbs +++ b/impls/vbs/const.vbs @@ -7,6 +7,9 @@ Const TYPE_KEYWORD = 5 Const TYPE_STRING = 6 Const TYPE_NUMBER = 7 Const TYPE_SYMBOL = 8 +Const TYPE_FUNCTION = 9 +Const TYPE_LAMBDA = 9 +Const TYPE_SPECIAL = 10 Class MalType Public [Type] diff --git a/impls/vbs/env.vbs b/impls/vbs/env.vbs index f4352352..240bfab0 100644 --- a/impls/vbs/env.vbs +++ b/impls/vbs/env.vbs @@ -9,6 +9,20 @@ class Environment Set objSelf = Nothing End Sub + Public Sub Init(objBinds, objExpressions) + 'MsgBox objExpressions.type + Dim i + For i = 0 To objBinds.Value.Count - 1 + Add objBinds.Value.Item(i).Value, _ + Evaluate(objExpressions.Value.Item(i+1), objSelf) + 'wsh.echo objBinds.Value.Item(i).Value + 'wsh.echo objExpressions.Value.Item(i).type + 'wsh.echo TypeName(Evaluate(objExpressions.Value.Item(i), objSelf)) + 'wsh.echo Evaluate(objExpressions.Value.Item(i), objSelf).type + Next + 'MsgBox objBindings("a") + End Sub + Public Function SetOuter(objEnv) Set objOuterEnv = objEnv End Function diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs index acb7947a..7d28f67e 100644 --- a/impls/vbs/printer.vbs +++ b/impls/vbs/printer.vbs @@ -1,6 +1,7 @@ Option Explicit Function PrintMalType(objMal, boolReadable) + 'MsgBox 1 PrintMalType = "" If TypeName(objMal) = "Nothing" Then Exit Function @@ -64,6 +65,8 @@ Function PrintMalType(objMal, boolReadable) PrintMalType = "nil" Case TYPE_NUMBER PrintMalType = CStr(objMal.Value) + Case TYPE_FUNCTION + PrintMalType = "#" Case Else PrintMalType = objMal.Value End Select diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs index e125c0f6..e6f27bdb 100644 --- a/impls/vbs/step3_env.vbs +++ b/impls/vbs/step3_env.vbs @@ -13,8 +13,6 @@ objEnv.Add "+", GetRef("Add") objEnv.Add "-", GetRef("Subtract") objEnv.Add "*", GetRef("Multiply") objEnv.Add "/", GetRef("Divide") -objEnv.Add "def!", GetRef("Divide") -objEnv.Add "let*", GetRef("Divide") Sub CheckArgNum(objArgs, lngExpect) From 4335edea68e9af8366d4572109c0e0360927ff99 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sun, 28 Aug 2022 15:47:05 +0800 Subject: [PATCH 13/44] step4 init:1 --- impls/vbs/step4_if_fn_do.vbs | 294 +++++++++++++++++++++++++++++++++++ 1 file changed, 294 insertions(+) create mode 100644 impls/vbs/step4_if_fn_do.vbs diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs new file mode 100644 index 00000000..54f11268 --- /dev/null +++ b/impls/vbs/step4_if_fn_do.vbs @@ -0,0 +1,294 @@ +Option Explicit + +Include "Const.vbs" +Include "Reader.vbs" +Include "Printer.vbs" +Include "Env.vbs" + +Dim objEnv +Set objEnv = New Environment +objEnv.SetSelf objEnv +objEnv.SetOuter Nothing +objEnv.Add "+", NewLambda(GetRef("Add")) +objEnv.Add "-", NewLambda(GetRef("Subtract")) +objEnv.Add "*", NewLambda(GetRef("Multiply")) +objEnv.Add "/", NewLambda(GetRef("Divide")) +objEnv.Add "def!", NewSpecialForm("def!") +objEnv.Add "let*", NewSpecialForm("let*") +objEnv.Add "do", NewSpecialForm("do") +objEnv.Add "if", NewSpecialForm("if") +objEnv.Add "fn*", NewSpecialForm("fn*") + +Function NewLambda(objFunction) + Dim objMal + Set objMal = New MalType + Set objMal.Value = New BuiltInFunction + Set objMal.Value.Run = objFunction + objMal.Type = TYPE_LAMBDA + Set NewLambda = objMal +End Function + +Class BuiltInFunction + Public Run +End Class + +Function NewSpecialForm(strValue) + Set NewSpecialForm = New MalType + NewSpecialForm.Value = strValue + NewSpecialForm.Type = TYPE_SPECIAL +End Function + +Function IsSpecialForm(objForm) + IsSpecialForm = (objForm.Type = TYPE_SPECIAL) +End Function + +Class SpecialForm + Public Value +End Class + +Sub CheckArgNum(objArgs, lngExpect) + If objArgs.Value.Count - 1 <> 2 Then + boolError = True + strError = "wrong number of arguments" + Call REPL() + End If +End Sub + +Function Add(objArgs) + CheckArgNum objArgs, 2 + Set Add = New MalType + Add.Type = TYPE_NUMBER + Add.Value = objArgs.Value.Item(1).Value + objArgs.Value.Item(2).Value +End Function + +Function Subtract(objArgs) + CheckArgNum objArgs, 2 + Set Subtract = New MalType + Subtract.Type = TYPE_NUMBER + Subtract.Value = objArgs.Value.Item(1).Value - objArgs.Value.Item(2).Value +End Function + +Function Multiply(objArgs) + CheckArgNum objArgs, 2 + Set Multiply = New MalType + Multiply.Type = TYPE_NUMBER + Multiply.Value = objArgs.Value.Item(1).Value * objArgs.Value.Item(2).Value +End Function + +Function Divide(objArgs) + CheckArgNum objArgs, 2 + Set Divide = New MalType + Divide.Type = TYPE_NUMBER + Divide.Value = objArgs.Value.Item(1).Value / objArgs.Value.Item(2).Value +End Function + + +Call REPL() +Sub REPL() + Dim strCode, strResult + While True + If boolError Then + WScript.StdErr.WriteLine "ERROR: " & strError + boolError = False + End If + 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 +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(objCode, objEnv) + Dim i + If TypeName(objCode) = "Nothing" Then + Call REPL() + End If + + If objCode.Type = TYPE_LIST Then + If objCode.Value.Count = 0 Then + Set Evaluate = objCode + Exit Function + End If + + Dim objSymbol + Set objSymbol = Evaluate(objCode.Value.Item(0), objEnv) + ' there's a bug that Item(0) maybe eval twice. + If IsSpecialForm(objSymbol) Then + 'MsgBox TypeName(objCode.value) + Select Case objSymbol.Value + Case "def!" + CheckArgNum objCode, 2 + CheckSymbol objCode.Value.Item(1) + objEnv.Add objCode.Value.Item(1).Value, _ + Evaluate(objCode.Value.Item(2), objEnv) + Set Evaluate = objEnv.Get(objCode.Value.Item(1).Value) + Case "let*" + Dim objNewEnv + Set objNewEnv = New Environment + objNewEnv.SetSelf objNewEnv + objNewEnv.SetOuter objEnv + CheckArgNum objCode, 2 + CheckListOrVector objCode.Value.Item(1) + CheckEven objCode.Value.Item(1).Value.Count + With objCode.Value.Item(1).Value + For i = 0 To .Count - 1 Step 2 + CheckSymbol .Item(i) + objNewEnv.Add .Item(i).Value, _ + Evaluate(.Item(i + 1), objNewEnv) + Next + End With + Set Evaluate = Evaluate(objCode.Value.Item(2), objNewEnv) + Case "do" + Set Evaluate = EvaluateAST(objCode, objEnv) + Set Evaluate = Evaluate.Value.Item(Evaluate.Value.Count - 1) + Case "if" + Dim objCondition + 'MsgBox 1 + Set objCondition = Evaluate(objCode.Value.Item(1), objEnv) + 'MsgBox 2 + If IsNil(objCondition) Or IsFalse(objCondition) Then + Select Case objCode.Value.Count - 1 + Case 2 + Set Evaluate = New MalType + Evaluate.Type = TYPE_NIL + Evaluate.Value = Null + Case 3 + Set Evaluate = Evaluate(objCode.Value.Item(3), objEnv) + Case Else + 'TODO Err + End Select + Else + If objCode.Value.Count - 1 = 2 Or objCode.Value.Count - 1 = 3 Then + Set Evaluate = Evaluate(objCode.Value.Item(2), objEnv) + Else + 'TODO err + End If + End If + Case "fn*" 'lambda + CheckArgNum objCode, 2 + Set Evaluate = New MalType + Evaluate.Type = TYPE_LAMBDA + Set Evaluate.Value = New Lambda + 'MsgBox 1 + Set Evaluate.Value.objEnv = New Environment + Evaluate.Value.objEnv.SetSelf Evaluate.Value.objEnv + Evaluate.Value.objEnv.SetOuter objEnv + Set Evaluate.Value.objParameters = objCode.Value.Item(1) + Set Evaluate.Value.objBody = objCode.Value.Item(2) + 'MsgBox 1 + End Select + Else + Set Evaluate = objSymbol.Value.Run(EvaluateAST(objCode, objEnv)) + End If + Else + Set Evaluate = EvaluateAST(objCode, objEnv) + End If +End Function + +Class Lambda + Public objEnv + Public objParameters + Public objBody + Public Function Run(objArgs) + 'MsgBox objArgs.type + objEnv.Init objParameters, objArgs + 'para start from 0, args start from 1 + Set Run = Evaluate(objBody, objEnv) + End Function +End Class + +Function IsFalse(objMal) + IsFalse = (objMal.Value = False) +End Function + +Function IsNil(objMal) + IsNil = (objMal.Type = TYPE_NIL) +End Function + +Sub CheckEven(lngNum) + If lngNum Mod 2 <> 0 Then + boolError = True + strError = "not a even number" + Call REPL() + End If +End Sub + +Sub CheckList(objMal) + If objMal.Type <> TYPE_LIST Then + boolError = True + strError = "neither a list nor a vector" + Call REPL() + End If +End Sub + +Sub CheckListOrVector(objMal) + If objMal.Type <> TYPE_LIST And objMal.Type <> TYPE_VECTOR Then + boolError = True + strError = "not a list" + Call REPL() + End If +End Sub + +Sub CheckSymbol(objMal) + If objMal.Type <> TYPE_SYMBOL Then + boolError = True + strError = "not a symbol" + Call REPL() + End If +End Sub + +Function EvaluateAST(objCode, objEnv) + If TypeName(objCode) = "Nothing" Then + MsgBox "Nothing2" + End If + + Dim objResult, i + Select Case objCode.Type + Case TYPE_SYMBOL + Set objResult = objEnv.Get(objCode.Value) + Case TYPE_LIST + For i = 0 To objCode.Value.Count - 1 + Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) + Next + Set objResult = objCode + Case TYPE_VECTOR + For i = 0 To objCode.Value.Count - 1 + Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) + Next + Set objResult = objCode + Case TYPE_HASHMAP + Dim arrKeys + arrKeys = objCode.Value.Keys + For i = 0 To objCode.Value.Count - 1 + Set objCode.Value.Item(arrKeys(i)) = _ + Evaluate(objCode.Value.Item(arrKeys(i)), objEnv) + Next + Set objResult = objCode + Case Else + Set objResult = objCode + End Select + Set EvaluateAST = objResult +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 \ No newline at end of file From 5d18234a3688141dd9d6f67bc2d8cd47a2b9ca41 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sun, 28 Aug 2022 21:33:05 +0800 Subject: [PATCH 14/44] add step4(have some bugs) --- impls/vbs/const.vbs | 17 ----- impls/vbs/env.vbs | 23 +++++- impls/vbs/printer.vbs | 1 + impls/vbs/reader.vbs | 1 - impls/vbs/step1_read_print.vbs | 2 +- impls/vbs/step2_eval.vbs | 4 +- impls/vbs/step3_env.vbs | 4 +- impls/vbs/step4_if_fn_do.vbs | 129 ++++++++++++++++----------------- 8 files changed, 89 insertions(+), 92 deletions(-) delete mode 100644 impls/vbs/const.vbs diff --git a/impls/vbs/const.vbs b/impls/vbs/const.vbs deleted file mode 100644 index 7db34a14..00000000 --- a/impls/vbs/const.vbs +++ /dev/null @@ -1,17 +0,0 @@ -Const TYPE_LIST = 0 -Const TYPE_VECTOR = 1 -Const TYPE_HASHMAP = 2 -Const TYPE_BOOLEAN = 3 -Const TYPE_NIL = 4 -Const TYPE_KEYWORD = 5 -Const TYPE_STRING = 6 -Const TYPE_NUMBER = 7 -Const TYPE_SYMBOL = 8 -Const TYPE_FUNCTION = 9 -Const TYPE_LAMBDA = 9 -Const TYPE_SPECIAL = 10 - -Class MalType - Public [Type] - Public Value -End Class diff --git a/impls/vbs/env.vbs b/impls/vbs/env.vbs index 240bfab0..a3f5099d 100644 --- a/impls/vbs/env.vbs +++ b/impls/vbs/env.vbs @@ -11,10 +11,27 @@ class Environment Public Sub Init(objBinds, objExpressions) 'MsgBox objExpressions.type - Dim i + Dim i,flag + flag = False For i = 0 To objBinds.Value.Count - 1 - Add objBinds.Value.Item(i).Value, _ - Evaluate(objExpressions.Value.Item(i+1), objSelf) + If objBinds.Value.Item(i).Value = "&" Then flag=True + If flag Then + 'assume i+1 = objBinds.Value.Count - 1 + Dim oTmp + Set oTmp = New MalType + oTmp.Type = TYPE_LIST + Set oTmp.Value = CreateObject("System.Collections.ArrayList") + Dim j + For j = i+1 To objExpressions.Value.Count - 1 + oTmp.Value.Add Evaluate(objExpressions.Value.Item(j), objSelf) + Next + 'MsgBox objBinds.Value.Item(i+1) + Add objBinds.Value.Item(i+1).Value, oTmp + Exit For + Else + Add objBinds.Value.Item(i).Value, _ + Evaluate(objExpressions.Value.Item(i+1), objSelf) + End If 'wsh.echo objBinds.Value.Item(i).Value 'wsh.echo objExpressions.Value.Item(i).type 'wsh.echo TypeName(Evaluate(objExpressions.Value.Item(i), objSelf)) diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs index 7d28f67e..e99f0e30 100644 --- a/impls/vbs/printer.vbs +++ b/impls/vbs/printer.vbs @@ -53,6 +53,7 @@ Function PrintMalType(objMal, boolReadable) If boolReadable Then PrintMalType = EscapeString(objMal.Value) Else + 'PrintMalType = """" & objMal.Value & """" PrintMalType = objMal.Value End If Case TYPE_BOOLEAN diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index 3dc1cb62..4497dbcd 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -200,7 +200,6 @@ Function ReadAtom(objTokens) objAtom.Value = False Case "nil" objAtom.Type = TYPE_NIL - objAtom.Value = Null Case Else Select Case Left(strAtom, 1) Case ":" diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs index 647522d7..3dd09014 100644 --- a/impls/vbs/step1_read_print.vbs +++ b/impls/vbs/step1_read_print.vbs @@ -1,6 +1,6 @@ Option Explicit -Include "Const.vbs" +Include "Core.vbs" Include "Reader.vbs" Include "Printer.vbs" diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs index 58c145ee..ba62218f 100644 --- a/impls/vbs/step2_eval.vbs +++ b/impls/vbs/step2_eval.vbs @@ -1,6 +1,6 @@ Option Explicit -Include "Const.vbs" +Include "Core.vbs" Include "Reader.vbs" Include "Printer.vbs" @@ -12,7 +12,7 @@ objEnv.Add "*", GetRef("Multiply") objEnv.Add "/", GetRef("Divide") Sub CheckArgNum(objArgs, lngExpect) - If objArgs.Value.Count - 1 <> 2 Then + If objArgs.Value.Count - 1 <> lngExpect Then boolError = True strError = "wrong number of arguments" Call REPL() diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs index e6f27bdb..b049384f 100644 --- a/impls/vbs/step3_env.vbs +++ b/impls/vbs/step3_env.vbs @@ -1,6 +1,6 @@ Option Explicit -Include "Const.vbs" +Include "Core.vbs" Include "Reader.vbs" Include "Printer.vbs" Include "Env.vbs" @@ -16,7 +16,7 @@ objEnv.Add "/", GetRef("Divide") Sub CheckArgNum(objArgs, lngExpect) - If objArgs.Value.Count - 1 <> 2 Then + If objArgs.Value.Count - 1 <> lngExpect Then boolError = True strError = "wrong number of arguments" Call REPL() diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs index 54f11268..3399600a 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -1,23 +1,28 @@ +'TODO ×Ö·û´®ÓÐÎÊÌâ +'TODO ¹þÏ£±íн¨Ã»Ð´ + Option Explicit -Include "Const.vbs" +Include "Core.vbs" Include "Reader.vbs" Include "Printer.vbs" Include "Env.vbs" -Dim objEnv -Set objEnv = New Environment -objEnv.SetSelf objEnv -objEnv.SetOuter Nothing -objEnv.Add "+", NewLambda(GetRef("Add")) -objEnv.Add "-", NewLambda(GetRef("Subtract")) -objEnv.Add "*", NewLambda(GetRef("Multiply")) -objEnv.Add "/", NewLambda(GetRef("Divide")) -objEnv.Add "def!", NewSpecialForm("def!") -objEnv.Add "let*", NewSpecialForm("let*") -objEnv.Add "do", NewSpecialForm("do") -objEnv.Add "if", NewSpecialForm("if") -objEnv.Add "fn*", NewSpecialForm("fn*") +Dim objRootEnv +Set objRootEnv = New Environment +objRootEnv.SetSelf objRootEnv +objRootEnv.SetOuter Nothing +Dim arrKeys, i +arrKeys = objCoreNS.Keys +For i = 0 To UBound(arrKeys) + objRootEnv.Add arrKeys(i), NewLambda(objCoreNS.Item(arrKeys(i))) +Next +objRootEnv.Add "def!", NewSpecialForm("def!") +objRootEnv.Add "let*", NewSpecialForm("let*") +objRootEnv.Add "do", NewSpecialForm("do") +objRootEnv.Add "if", NewSpecialForm("if") +objRootEnv.Add "fn*", NewSpecialForm("fn*") +REP "(def! not (fn* (a) (if a false true)))" Function NewLambda(objFunction) Dim objMal @@ -28,10 +33,6 @@ Function NewLambda(objFunction) Set NewLambda = objMal End Function -Class BuiltInFunction - Public Run -End Class - Function NewSpecialForm(strValue) Set NewSpecialForm = New MalType NewSpecialForm.Value = strValue @@ -47,42 +48,13 @@ Class SpecialForm End Class Sub CheckArgNum(objArgs, lngExpect) - If objArgs.Value.Count - 1 <> 2 Then + If objArgs.Value.Count - 1 <> lngExpect Then boolError = True strError = "wrong number of arguments" Call REPL() End If End Sub -Function Add(objArgs) - CheckArgNum objArgs, 2 - Set Add = New MalType - Add.Type = TYPE_NUMBER - Add.Value = objArgs.Value.Item(1).Value + objArgs.Value.Item(2).Value -End Function - -Function Subtract(objArgs) - CheckArgNum objArgs, 2 - Set Subtract = New MalType - Subtract.Type = TYPE_NUMBER - Subtract.Value = objArgs.Value.Item(1).Value - objArgs.Value.Item(2).Value -End Function - -Function Multiply(objArgs) - CheckArgNum objArgs, 2 - Set Multiply = New MalType - Multiply.Type = TYPE_NUMBER - Multiply.Value = objArgs.Value.Item(1).Value * objArgs.Value.Item(2).Value -End Function - -Function Divide(objArgs) - CheckArgNum objArgs, 2 - Set Divide = New MalType - Divide.Type = TYPE_NUMBER - Divide.Value = objArgs.Value.Item(1).Value / objArgs.Value.Item(2).Value -End Function - - Call REPL() Sub REPL() Dim strCode, strResult @@ -118,7 +90,6 @@ Function Evaluate(objCode, objEnv) Dim objSymbol Set objSymbol = Evaluate(objCode.Value.Item(0), objEnv) - ' there's a bug that Item(0) maybe eval twice. If IsSpecialForm(objSymbol) Then 'MsgBox TypeName(objCode.value) Select Case objSymbol.Value @@ -152,12 +123,14 @@ Function Evaluate(objCode, objEnv) 'MsgBox 1 Set objCondition = Evaluate(objCode.Value.Item(1), objEnv) 'MsgBox 2 + 'MsgBox IsNil(objCondition) + 'MsgBox IsFalse(objCondition) If IsNil(objCondition) Or IsFalse(objCondition) Then + 'MsgBox 1 Select Case objCode.Value.Count - 1 Case 2 Set Evaluate = New MalType Evaluate.Type = TYPE_NIL - Evaluate.Value = Null Case 3 Set Evaluate = Evaluate(objCode.Value.Item(3), objEnv) Case Else @@ -184,27 +157,53 @@ Function Evaluate(objCode, objEnv) 'MsgBox 1 End Select Else + 'MsgBox 2 + 'objSymbol.Value.SetEnv objEnv Set Evaluate = objSymbol.Value.Run(EvaluateAST(objCode, objEnv)) + 'MsgBox objEnv.Get("N").value + 'MsgBox 3 End If Else Set Evaluate = EvaluateAST(objCode, objEnv) End If End Function +Class BuiltInFunction + Public Run + Public Sub SetEnv(z) + End Sub +End Class + Class Lambda - Public objEnv Public objParameters Public objBody + Public objEnv + Public Function SetEnv(oInv) + Set objEnv=oInv + End Function + Public Function Run(objArgs) + Dim objNewEnv + Set objNewEnv = New Environment + objNewEnv.SetSelf objNewEnv + objNewEnv.SetOuter objEnv 'MsgBox objArgs.type - objEnv.Init objParameters, objArgs + objNewEnv.Init objParameters, objArgs 'para start from 0, args start from 1 - Set Run = Evaluate(objBody, objEnv) + 'MsgBox objNewEnv.Get("N").value + Set Run = Evaluate(objBody, objNewEnv) End Function End Class +Function IsZero(objMal) + IsZero = (objMal.Type = TYPE_NUMBER And objMal.Value = 0) + 'MsgBox IsZero +End Function + Function IsFalse(objMal) - IsFalse = (objMal.Value = False) + IsFalse = (objMal.Type = TYPE_BOOLEAN) + If Not IsFalse Then Exit Function + IsFalse = IsFalse And (objMal.Value = False) End Function Function IsNil(objMal) @@ -253,23 +252,21 @@ Function EvaluateAST(objCode, objEnv) Case TYPE_SYMBOL Set objResult = objEnv.Get(objCode.Value) Case TYPE_LIST + Set objResult = New MalType + Set objResult.Value = CreateObject("System.Collections.ArrayList") + objResult.Type = TYPE_LIST For i = 0 To objCode.Value.Count - 1 - Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) + objResult.Value.Add Evaluate(objCode.Value.Item(i), objEnv) Next - Set objResult = objCode Case TYPE_VECTOR + Set objResult = New MalType + Set objResult.Value = CreateObject("System.Collections.ArrayList") + objResult.Type = TYPE_VECTOR For i = 0 To objCode.Value.Count - 1 - Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) + objResult.Value.Add Evaluate(objCode.Value.Item(i), objEnv) Next - Set objResult = objCode Case TYPE_HASHMAP - Dim arrKeys - arrKeys = objCode.Value.Keys - For i = 0 To objCode.Value.Count - 1 - Set objCode.Value.Item(arrKeys(i)) = _ - Evaluate(objCode.Value.Item(arrKeys(i)), objEnv) - Next - Set objResult = objCode + 'TODO: new hashMap Case Else Set objResult = objCode End Select @@ -281,7 +278,7 @@ Function Print(objCode) End Function Function REP(strCode) - REP = Print(Evaluate(Read(strCode), objEnv)) + REP = Print(Evaluate(Read(strCode), objRootEnv)) End Function Sub Include(strFileName) From 3916d71097266a6411fbc5f5e2e926f7f6a5c72c Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sun, 28 Aug 2022 21:36:38 +0800 Subject: [PATCH 15/44] core miss, added --- impls/vbs/core.vbs | 243 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 243 insertions(+) create mode 100644 impls/vbs/core.vbs diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs new file mode 100644 index 00000000..949cea4e --- /dev/null +++ b/impls/vbs/core.vbs @@ -0,0 +1,243 @@ +Const TYPE_LIST = 0 +Const TYPE_VECTOR = 1 +Const TYPE_HASHMAP = 2 +Const TYPE_BOOLEAN = 3 +Const TYPE_NIL = 4 +Const TYPE_KEYWORD = 5 +Const TYPE_STRING = 6 +Const TYPE_NUMBER = 7 +Const TYPE_SYMBOL = 8 +Const TYPE_FUNCTION = 9 +Const TYPE_LAMBDA = 9 +Const TYPE_SPECIAL = 10 + +Class MalType + Public [Type] + Public Value +End Class + +Public objCoreNS +Set objCoreNS = CreateObject("Scripting.Dictionary") +objCoreNS.Add "+", GetRef("Add") +objCoreNS.Add "-", GetRef("Subtract") +objCoreNS.Add "*", GetRef("Multiply") +objCoreNS.Add "/", GetRef("Divide") +objCoreNS.Add "list", GetRef("mMakeList") +objCoreNS.Add "list?", GetRef("mIsList") '1 +objCoreNS.Add "empty?", GetRef("mIsListEmpty") '1 +objCoreNS.Add "count", GetRef("mListCount") '1 +objCoreNS.Add "=", GetRef("mEqual") '2 'both type & value +objCoreNS.Add "<", GetRef("mLess") '2 'number only +objCoreNS.Add ">", GetRef("mGreater") '2 'number only +objCoreNS.Add "<=", GetRef("mEqualLess") '2 'number only +objCoreNS.Add ">=", GetRef("mEqualGreater") '2 'number only +objCoreNS.Add "pr-str", GetRef("mprstr") 'all 'ret str 'readable 'concat by space +objCoreNS.Add "str", GetRef("mstr") 'all 'ret str '!readable 'concat by "" +objCoreNS.Add "prn", GetRef("mprn") 'all 'to screen ret nil 'concat by space 'readable +objCoreNS.Add "println", GetRef("mprintln") 'all 'to screen ret nil 'concat by space '!readable + + +Function mprintln(objArgs) + Dim objRes,i + Set objRes = New MalType + objRes.Type = TYPE_NIL + For i = 1 To objArgs.Value.Count - 2 + wsh.stdout.write PrintMalType(objArgs.Value.Item(i), False) & " " + Next + If objArgs.Value.Count - 1 > 0 Then + wsh.stdout.write PrintMalType(objArgs.Value.Item(objArgs.Value.Count - 1), False) + End If + Set mprintln=objRes +End Function + +Function mprn(objArgs) + Dim objRes,i + Set objRes = New MalType + objRes.Type = TYPE_NIL + For i = 1 To objArgs.Value.Count - 2 + wsh.stdout.write PrintMalType(objArgs.Value.Item(i), True) & " " + Next + If objArgs.Value.Count - 1 > 0 Then + wsh.stdout.write PrintMalType(objArgs.Value.Item(objArgs.Value.Count - 1), True) + End If + Set mprn=objRes +End Function + +Function mstr(objArgs) + Dim objRes,i + Set objRes = New MalType + objRes.Type = TYPE_STRING + objRes.Value = "" + For i = 1 To objArgs.Value.Count - 1 + objRes.Value = objRes.Value & PrintMalType(objArgs.Value.Item(i), False) + Next + Set mstr=objRes +End Function + +Function mprstr(objArgs) + Dim objRes,i + Set objRes = New MalType + objRes.Type = TYPE_STRING + objRes.Value = "" + For i = 1 To objArgs.Value.Count - 2 + objRes.Value = objRes.Value & PrintMalType(objArgs.Value.Item(i), True) & " " + Next + If objArgs.Value.Count - 1 > 0 Then + objRes.Value = objRes.Value & PrintMalType(objArgs.Value.Item(objArgs.Value.Count - 1), True) + End If + Set mprstr=objRes +End Function + +Function mEqualGreater(objArgs) + CheckArgNum objArgs, 2 + Dim objRes,i + Set objRes = New MalType + objRes.Type = TYPE_BOOLEAN + objRes.Value = (objArgs.Value.Item(1).Value >= objArgs.Value.Item(2).Value) + Set mEqualGreater = objRes +End Function + +Function mEqualLess(objArgs) + CheckArgNum objArgs, 2 + Dim objRes,i + Set objRes = New MalType + objRes.Type = TYPE_BOOLEAN + objRes.Value = (objArgs.Value.Item(1).Value <= objArgs.Value.Item(2).Value) + Set mEqualLess = objRes +End Function + +Function mGreater(objArgs) + CheckArgNum objArgs, 2 + Dim objRes,i + Set objRes = New MalType + objRes.Type = TYPE_BOOLEAN + objRes.Value = (objArgs.Value.Item(1).Value > objArgs.Value.Item(2).Value) + Set mGreater = objRes +End Function + + +Function mLess(objArgs) + CheckArgNum objArgs, 2 + Dim objRes,i + Set objRes = New MalType + objRes.Type = TYPE_BOOLEAN + objRes.Value = (objArgs.Value.Item(1).Value < objArgs.Value.Item(2).Value) + Set mLess = objRes +End Function + + +Function mEqual(objArgs) + CheckArgNum objArgs, 2 + Dim objRes,i + Set objRes = New MalType + objRes.Type = TYPE_BOOLEAN + objRes.Value = (objArgs.Value.Item(1).Type = objArgs.Value.Item(2).Type) Or _ + ((objArgs.Value.Item(1).Type = TYPE_LIST Or objArgs.Value.Item(1).Type = TYPE_VECTOR) And _ + (objArgs.Value.Item(2).Type = TYPE_LIST Or objArgs.Value.Item(2).Type = TYPE_VECTOR)) + If objRes.Value Then + 'MsgBox objArgs.Value.Item(1).Type + If objArgs.Value.Item(1).Type = TYPE_LIST Or objArgs.Value.Item(1).Type = TYPE_VECTOR Then + objRes.Value = _ + (objArgs.Value.Item(1).Value.Count = objArgs.Value.Item(2).Value.Count) + If objRes.Value Then + Dim objTemp + For i = 0 To objArgs.Value.Item(1).Value.Count - 1 + 'an ugly recursion + + 'MsgBox objArgs.Value.Item(1).Value.Item(i).type + Set objTemp = New MalType + objTemp.Type = TYPE_LIST + Set objTemp.Value = CreateObject("System.Collections.Arraylist") + objTemp.Value.Add Null + objTemp.Value.Add objArgs.Value.Item(1).Value.Item(i) + objTemp.Value.Add objArgs.Value.Item(2).Value.Item(i) + + objRes.Value = objRes.Value And mEqual(objTemp).Value + Next + End If + Else + 'MsgBox objArgs.Value.Item(1).Value + 'MsgBox objArgs.Value.Item(2).Value + objRes.Value = _ + (objArgs.Value.Item(1).Value = objArgs.Value.Item(2).Value) + End If + End If + Set mEqual = objRes +End Function + +Sub Er(sInfo) + boolError = True + strError = sInfo +End Sub + +Function mListCount(objArgs) + CheckArgNum objArgs, 1 + Dim objRes,i + Set objRes = New MalType + objRes.Type = TYPE_NUMBER + If objArgs.Value.Item(1).Type = TYPE_LIST Then + objRes.Value = objArgs.Value.Item(1).Value.Count + ElseIf objArgs.Value.Item(1).Type = TYPE_NIL Then + objRes.Value = 0 + Else + Er "can't count" + End If + Set mListCount = objRes +End Function + +Function mIsListEmpty(objArgs) + CheckArgNum objArgs, 1 + Dim objRes,i + Set objRes = New MalType + objRes.Type = TYPE_BOOLEAN + objRes.Value = (objArgs.Value.Item(1).Value.Count = 0) + Set mIsListEmpty = objRes +End Function + +Function mIsList(objArgs) + CheckArgNum objArgs, 1 + Dim objRes,i + Set objRes = New MalType + objRes.Type = TYPE_BOOLEAN + objRes.Value = (objArgs.Value.Item(1).Type = TYPE_LIST) + Set mIsList = objRes +End Function + +Function mMakeList(objArgs) + Dim objRes,i + Set objRes = New MalType + objRes.Type = TYPE_LIST + Set objRes.Value = CreateObject("System.Collections.ArrayList") + For i = 1 To objArgs.Value.Count - 1 + objRes.Value.Add objArgs.Value.Item(i) + Next + Set mMakeList = objRes +End Function + +Function Add(objArgs) + CheckArgNum objArgs, 2 + Set Add = New MalType + Add.Type = TYPE_NUMBER + Add.Value = objArgs.Value.Item(1).Value + objArgs.Value.Item(2).Value +End Function + +Function Subtract(objArgs) + CheckArgNum objArgs, 2 + Set Subtract = New MalType + Subtract.Type = TYPE_NUMBER + Subtract.Value = objArgs.Value.Item(1).Value - objArgs.Value.Item(2).Value +End Function + +Function Multiply(objArgs) + CheckArgNum objArgs, 2 + Set Multiply = New MalType + Multiply.Type = TYPE_NUMBER + Multiply.Value = objArgs.Value.Item(1).Value * objArgs.Value.Item(2).Value +End Function + +Function Divide(objArgs) + CheckArgNum objArgs, 2 + Set Divide = New MalType + Divide.Type = TYPE_NUMBER + Divide.Value = objArgs.Value.Item(1).Value / objArgs.Value.Item(2).Value +End Function \ No newline at end of file From 3502571a4e95613d679ee2870fc2da7ccaf32b74 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sun, 23 Oct 2022 12:47:04 +0800 Subject: [PATCH 16/44] fix fn* calling bug which evaluate code twice --- impls/vbs/core.vbs | 27 ++++++++++++++++- impls/vbs/step0_repl.vbs | 2 +- impls/vbs/step2_eval.vbs | 2 +- impls/vbs/step3_env.vbs | 2 +- impls/vbs/step4_if_fn_do.vbs | 56 ++++++++++++++++++++++++++++++++++-- 5 files changed, 83 insertions(+), 6 deletions(-) diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index 949cea4e..23ed3abe 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -35,7 +35,32 @@ objCoreNS.Add "pr-str", GetRef("mprstr") 'all 'ret str 'readable 'concat by spac objCoreNS.Add "str", GetRef("mstr") 'all 'ret str '!readable 'concat by "" objCoreNS.Add "prn", GetRef("mprn") 'all 'to screen ret nil 'concat by space 'readable objCoreNS.Add "println", GetRef("mprintln") 'all 'to screen ret nil 'concat by space '!readable +objCoreNS.Add "get", GetRef("mGet") +objCoreNS.Add "set", GetRef("mSet") +Function mGet(objArgs) + Set objRes = New MalType + 'objRes.Type = + Set objList = objArgs.value.item(1) + numIndex = objArgs.value.item(2).value + Set objRes = objList.value.Item(numIndex) + 'MsgBox objRes.type + Set mGet = objRes +End Function + +Function mSet(objArgs) + Set objRes = New MalType + 'objRes.Type = + 'MsgBox 1 + Set objList = objArgs.value.item(1) + numIndex = objArgs.value.item(2).value + 'MsgBox numIndex + Set objReplace = objArgs.value.item(3) + Set objList.value.Item(numIndex) = objReplace + 'MsgBox objRes.type + Set mSet = New MalType + mSet.Type = TYPE_NIL +End Function Function mprintln(objArgs) Dim objRes,i @@ -239,5 +264,5 @@ Function Divide(objArgs) CheckArgNum objArgs, 2 Set Divide = New MalType Divide.Type = TYPE_NUMBER - Divide.Value = objArgs.Value.Item(1).Value / objArgs.Value.Item(2).Value + Divide.Value = objArgs.Value.Item(1).Value \ objArgs.Value.Item(2).Value End Function \ No newline at end of file diff --git a/impls/vbs/step0_repl.vbs b/impls/vbs/step0_repl.vbs index bc9d6e32..862e690e 100644 --- a/impls/vbs/step0_repl.vbs +++ b/impls/vbs/step0_repl.vbs @@ -24,4 +24,4 @@ While True 'REPL If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 WScript.Echo REP(strCode) -WEnd +Wend diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs index ba62218f..bc5123ad 100644 --- a/impls/vbs/step2_eval.vbs +++ b/impls/vbs/step2_eval.vbs @@ -44,7 +44,7 @@ Function Divide(objArgs) CheckArgNum objArgs, 2 Set Divide = New MalType Divide.Type = TYPE_NUMBER - Divide.Value = objArgs.Value.Item(1).Value / objArgs.Value.Item(2).Value + Divide.Value = objArgs.Value.Item(1).Value \ objArgs.Value.Item(2).Value End Function diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs index b049384f..2a5d0b23 100644 --- a/impls/vbs/step3_env.vbs +++ b/impls/vbs/step3_env.vbs @@ -48,7 +48,7 @@ Function Divide(objArgs) CheckArgNum objArgs, 2 Set Divide = New MalType Divide.Type = TYPE_NUMBER - Divide.Value = objArgs.Value.Item(1).Value / objArgs.Value.Item(2).Value + Divide.Value = objArgs.Value.Item(1).Value \ objArgs.Value.Item(2).Value End Function diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs index 3399600a..6922cfca 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -2,7 +2,10 @@ 'TODO ¹þÏ£±íн¨Ã»Ð´ Option Explicit - +Dim DEPTH +DEPTH = 0 +Dim CALLFROM +CALLFROM = "" Include "Core.vbs" Include "Reader.vbs" Include "Printer.vbs" @@ -76,7 +79,9 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function + Function Evaluate(objCode, objEnv) + DEPTH = DEPTH + 1 Dim i If TypeName(objCode) = "Nothing" Then Call REPL() @@ -89,11 +94,16 @@ Function Evaluate(objCode, objEnv) End If Dim objSymbol + 'wsh.echo space(DEPTH*4)&"CHECK FIRST" Set objSymbol = Evaluate(objCode.Value.Item(0), objEnv) + 'wsh.echo space(DEPTH*4)&"CHECK FIRST FINISH" + 'MsgBox objSymbol.type If IsSpecialForm(objSymbol) Then + 'wsh.echo space(DEPTH*4)&"EVAL SPECIAL" 'MsgBox TypeName(objCode.value) Select Case objSymbol.Value Case "def!" + 'MsgBox "ÎÒÔÚdef" CheckArgNum objCode, 2 CheckSymbol objCode.Value.Item(1) objEnv.Add objCode.Value.Item(1).Value, _ @@ -156,19 +166,53 @@ Function Evaluate(objCode, objEnv) Set Evaluate.Value.objBody = objCode.Value.Item(2) 'MsgBox 1 End Select + 'wsh.echo space(DEPTH*4)&"EVAL SPECIAL FINISH" Else + 'wsh.echo space(DEPTH*4)&"EVAL NORMAL" 'MsgBox 2 'objSymbol.Value.SetEnv objEnv - Set Evaluate = objSymbol.Value.Run(EvaluateAST(objCode, objEnv)) + 'wsh.echo space(DEPTH*4)&"objcode","type",objCode.Type + 'If objCode.Type = 7 Then wsh.echo space(DEPTH*4)&objCode.value + 'If objCode.Type = 8 Then wsh.echo space(DEPTH*4)&objCode.value + 'If objCode.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(objCode,True) + + 'ÕâÀïÓдóÎÊÌâ + If objSymbol.Value.IsBuiltIn Then + Set Evaluate = objSymbol.Value.Run(objCode) + Else + Set Evaluate = objSymbol.Value.Run(EvaluateAST(objCode, objEnv)) + End If + 'wsh.echo space(DEPTH*4)&"evaluate","type",Evaluate.Type + 'If Evaluate.Type = 7 Then wsh.echo space(DEPTH*4)&Evaluate.value + 'If Evaluate.Type = 8 Then wsh.echo space(DEPTH*4)&Evaluate.value + 'If Evaluate.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(Evaluate,True) + 'Set Evaluate = Evaluate(objCode, objEnv) + 'MsgBox Evaluate.type 'MsgBox objEnv.Get("N").value 'MsgBox 3 + 'wsh.echo space(DEPTH*4)&"EVAL NORMAL FINISH" End If Else + 'wsh.echo space(DEPTH*4)&"objcode","type",objCode.Type + 'If objCode.Type = 7 Then wsh.echo space(DEPTH*4)&objCode.value + 'If objCode.Type = 8 Then wsh.echo space(DEPTH*4)&objCode.value + 'If objCode.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(objCode,True) Set Evaluate = EvaluateAST(objCode, objEnv) + 'wsh.echo space(DEPTH*4)&"evaluate","type",Evaluate.Type + 'If Evaluate.Type = 7 Then wsh.echo space(DEPTH*4)&Evaluate.value + 'If Evaluate.Type = 8 Then wsh.echo space(DEPTH*4)&Evaluate.value + 'If Evaluate.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(Evaluate,True) + 'wsh.echo "" End If + 'wsh.echo space(DEPTH*4)&"RETURN" + DEPTH = DEPTH - 1 End Function Class BuiltInFunction + Public IsBuiltIn + Public Sub Class_Initialize + IsBuiltIn = False + End Sub Public Run Public Sub SetEnv(z) End Sub @@ -178,6 +222,10 @@ Class Lambda Public objParameters Public objBody Public objEnv + Public IsBuiltIn + Public Sub Class_Initialize + IsBuiltIn = True + End Sub Public Function SetEnv(oInv) Set objEnv=oInv End Function @@ -191,7 +239,11 @@ Class Lambda objNewEnv.Init objParameters, objArgs 'para start from 0, args start from 1 'MsgBox objNewEnv.Get("N").value + 'wsh.echo space(DEPTH*4)&"RUN "& PrintMalType(objBody,True) Set Run = Evaluate(objBody, objNewEnv) + 'wsh.echo space(DEPTH*4)&"RUN FINISH" + 'MsgBox Run.type + 'MsgBox Run.value End Function End Class From 71cd8a8e37c3091c90fd95cb7134f7bdc26b6690 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E8=80=81=E5=88=98?= <632171029@qq.com> Date: Sun, 30 Oct 2022 20:20:57 +0800 Subject: [PATCH 17/44] fix env's big bug Env binding should happen in function calling --- .gitignore | 1 + impls/vbs/core.vbs | 19 +++++++++++++++ impls/vbs/reader.vbs | 46 ++++++++++++++++++------------------ impls/vbs/step4_if_fn_do.vbs | 33 ++++++++++++++++---------- 4 files changed, 64 insertions(+), 35 deletions(-) diff --git a/.gitignore b/.gitignore index 80c2c84a..7062d7fd 100644 --- a/.gitignore +++ b/.gitignore @@ -22,3 +22,4 @@ GRTAGS logs old tmp/ +impls/\#batch/* diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index 23ed3abe..3bbb5124 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -37,6 +37,25 @@ objCoreNS.Add "prn", GetRef("mprn") 'all 'to screen ret nil 'concat by space 're objCoreNS.Add "println", GetRef("mprintln") 'all 'to screen ret nil 'concat by space '!readable objCoreNS.Add "get", GetRef("mGet") objCoreNS.Add "set", GetRef("mSet") +objCoreNS.Add "first", GetRef("mFirst") +objCoreNS.Add "last", GetRef("mLast") + +Function mLast(objArgs) + Set objRes = New MalType + objRes.Type = TYPE_LIST + set objRes.value = createobject("system.collections.arraylist") + for i = 1 to objArgs.value.item(1).value.count - 1 + objRes.value.add objArgs.value.item(1).value.item(i) + next + Set mLast= objRes +End Function + +Function mFirst(objArgs) + 'Set objRes = New MalType + Set objRes = objArgs.value.item(1).value.item(0) + Set mFirst= objRes + 'msgbox 1 +End Function Function mGet(objArgs) Set objRes = New MalType diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index 4497dbcd..2902a451 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -8,11 +8,11 @@ Function Tokenize(strCode) Dim objRE Set objRE = New RegExp With objRE - .Pattern = "[\s,]*(~@|[\[\]{}()'`~^@]|""(?:\\.|[^\\""])*""?|;.*|[^\s\[\]{}('""`,;)]*)" + .Pattern = "[\s,]*(~@|[\[\]{}()'`~^@]|""(?:\\.|[^\\""])*""?|;.*|[^\s\[\]{}('""`,;)]*)" .IgnoreCase = True .Global = True End With - + Dim objTokens, objMatches, objMatch Set objTokens = CreateObject("System.Collections.Queue") Set objMatches = objRE.Execute(strCode) @@ -23,7 +23,7 @@ Function Tokenize(strCode) objTokens.Enqueue strToken End If Next - + Set Tokenize = objTokens End Function @@ -34,16 +34,16 @@ Function ReadForm(objTokens) Set ReadForm = Nothing Exit Function End If - + If objTokens.Count = 1 And objTokens.Peek() = "" Then Call objTokens.Dequeue() Set ReadForm = Nothing Exit Function End If - + Dim strToken strToken = objTokens.Peek() - + If InStr("([{", strToken) Then Select Case strToken Case "(" @@ -55,7 +55,7 @@ Function ReadForm(objTokens) End Select ElseIf InStr("'`~@", strToken) Then Call objTokens.Dequeue() - + Dim strAlias Select Case strToken Case "'" @@ -73,7 +73,7 @@ Function ReadForm(objTokens) strError = "unknown token " & strAlias Call REPL() End Select - + Set ReadForm = New MalType ReadForm.Type = TYPE_LIST Set ReadForm.Value = CreateObject("System.Collections.ArrayList") @@ -83,7 +83,7 @@ Function ReadForm(objTokens) ReadForm.Value.Add ReadForm(objTokens) ElseIf InStr(")]}", strToken) Then Call objTokens.Dequeue() - + boolError = True strError = "unbalanced parentheses" Call REPL() @@ -106,13 +106,13 @@ End Function Function ReadList(objTokens) Call objTokens.Dequeue() - + If objTokens.Count = 0 Then boolError = True strError = "unbalanced parentheses" Call REPL() End If - + Set ReadList = New MalType Set ReadList.Value = CreateObject("System.Collections.ArrayList") ReadList.Type = TYPE_LIST @@ -122,7 +122,7 @@ Function ReadList(objTokens) .Add ReadForm(objTokens) Wend End With - + If objTokens.Dequeue() <> ")" Then boolError = True strError = "unbalanced parentheses" @@ -132,23 +132,23 @@ End Function function ReadVector(objTokens) Call objTokens.Dequeue() - + If objTokens.Count = 0 Then boolError = True strError = "unbalanced parentheses" Call REPL() End If - + Set ReadVector = New MalType Set ReadVector.Value = CreateObject("System.Collections.ArrayList") ReadVector.Type = TYPE_VECTOR - + With ReadVector.Value While objTokens.Count > 1 And objTokens.Peek() <> "]" .Add ReadForm(objTokens) Wend End With - + If objTokens.Dequeue() <> "]" Then boolError = True strError = "unbalanced parentheses" @@ -158,7 +158,7 @@ End Function Function ReadHashmap(objTokens) Call objTokens.Dequeue() - + If objTokens.Count = 0 Then boolError = True strError = "unbalanced parentheses" @@ -168,7 +168,7 @@ Function ReadHashmap(objTokens) Set ReadHashmap = New MalType Set ReadHashmap.Value = CreateObject("Scripting.Dictionary") ReadHashmap.Type = TYPE_HASHMAP - + Dim objKey, objValue With ReadHashmap.Value While objTokens.Count > 2 And objTokens.Peek() <> "}" @@ -177,7 +177,7 @@ Function ReadHashmap(objTokens) .Add objKey, objValue Wend End With - + If objTokens.Dequeue() <> "}" Then boolError = True strError = "unbalanced parentheses" @@ -188,7 +188,7 @@ End Function Function ReadAtom(objTokens) Dim strAtom strAtom = objTokens.Dequeue() - + Dim objAtom Set objAtom = New MalType Select Case strAtom @@ -218,7 +218,7 @@ Function ReadAtom(objTokens) End If End Select End Select - + Set ReadAtom = objAtom End Function @@ -228,7 +228,7 @@ Function ParseString(strRaw) strError = "unterminated string, got EOF" Call REPL() End If - + Dim strTemp strTemp = Mid(strRaw, 2, Len(strRaw) - 2) Dim i @@ -248,7 +248,7 @@ Function ParseString(strRaw) End Select i = i + 2 Wend - + If i <= Len(strTemp) Then ' Last char is not processed. If Right(strTemp, 1) <> "\" Then diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs index 6922cfca..73ccc70c 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -1,5 +1,4 @@ 'TODO ×Ö·û´®ÓÐÎÊÌâ -'TODO ¹þÏ£±íн¨Ã»Ð´ Option Explicit Dim DEPTH @@ -86,13 +85,13 @@ Function Evaluate(objCode, objEnv) If TypeName(objCode) = "Nothing" Then Call REPL() End If - + If objCode.Type = TYPE_LIST Then If objCode.Value.Count = 0 Then Set Evaluate = objCode Exit Function End If - + Dim objSymbol 'wsh.echo space(DEPTH*4)&"CHECK FIRST" Set objSymbol = Evaluate(objCode.Value.Item(0), objEnv) @@ -159,9 +158,9 @@ Function Evaluate(objCode, objEnv) Evaluate.Type = TYPE_LAMBDA Set Evaluate.Value = New Lambda 'MsgBox 1 - Set Evaluate.Value.objEnv = New Environment - Evaluate.Value.objEnv.SetSelf Evaluate.Value.objEnv - Evaluate.Value.objEnv.SetOuter objEnv + 'Set Evaluate.Value.objEnv = New Environment + 'Evaluate.Value.objEnv.SetSelf Evaluate.Value.objEnv + 'Evaluate.Value.objEnv.SetOuter objEnv Set Evaluate.Value.objParameters = objCode.Value.Item(1) Set Evaluate.Value.objBody = objCode.Value.Item(2) 'MsgBox 1 @@ -175,10 +174,14 @@ Function Evaluate(objCode, objEnv) 'If objCode.Type = 7 Then wsh.echo space(DEPTH*4)&objCode.value 'If objCode.Type = 8 Then wsh.echo space(DEPTH*4)&objCode.value 'If objCode.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(objCode,True) - + 'ÕâÀïÓдóÎÊÌâ If objSymbol.Value.IsBuiltIn Then + Set objSymbol.Value.objEnv = New Environment + objSymbol.Value.objEnv.SetSelf objSymbol.Value.objEnv + objSymbol.Value.objEnv.SetOuter objEnv Set Evaluate = objSymbol.Value.Run(objCode) + Else Set Evaluate = objSymbol.Value.Run(EvaluateAST(objCode, objEnv)) End If @@ -229,7 +232,7 @@ Class Lambda Public Function SetEnv(oInv) Set objEnv=oInv End Function - + Public Function Run(objArgs) Dim objNewEnv Set objNewEnv = New Environment @@ -267,7 +270,7 @@ Sub CheckEven(lngNum) boolError = True strError = "not a even number" Call REPL() - End If + End If End Sub Sub CheckList(objMal) @@ -298,7 +301,7 @@ Function EvaluateAST(objCode, objEnv) If TypeName(objCode) = "Nothing" Then MsgBox "Nothing2" End If - + Dim objResult, i Select Case objCode.Type Case TYPE_SYMBOL @@ -318,7 +321,13 @@ Function EvaluateAST(objCode, objEnv) objResult.Value.Add Evaluate(objCode.Value.Item(i), objEnv) Next Case TYPE_HASHMAP - 'TODO: new hashMap + Set objResult = New MalType + Set objResult.Value = CreateObject("Scripting.Dictionary") + objResult.Type = TYPE_HASHMAP + Dim key + For Each key In objCode.Value.Keys + objResult.Value.Add Evaluate(key, objEnv), Evaluate(objCode.Value.Item(key), objEnv) + Next Case Else Set objResult = objCode End Select @@ -340,4 +349,4 @@ Sub Include(strFileName) .GetFile(WScript.ScriptFullName)) & _ "\" & strFileName).ReadAll End With -End Sub \ No newline at end of file +End Sub From d9b22412be34044bf8b84b92f4227294edff1bfb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E8=80=81=E5=88=98?= <632171029@qq.com> Date: Sun, 30 Oct 2022 20:55:17 +0800 Subject: [PATCH 18/44] env hotfix combine env(when fn created) and running env into one --- impls/vbs/.step4_if_fn_do.vbs.swp | Bin 0 -> 24576 bytes impls/vbs/step4_if_fn_do.vbs | 12 +++++++----- 2 files changed, 7 insertions(+), 5 deletions(-) create mode 100644 impls/vbs/.step4_if_fn_do.vbs.swp diff --git a/impls/vbs/.step4_if_fn_do.vbs.swp b/impls/vbs/.step4_if_fn_do.vbs.swp new file mode 100644 index 0000000000000000000000000000000000000000..12430fdb5ea61e6e5578d783524559f9a220f618 GIT binary patch literal 24576 zcmeI33yfS>d4MlXLNW#1kc3Eu2CgTGJ!3ZGS869|9kP#Edz9Us&F*>^P{Enqx$B*H zcJ4BdwH>uU8>0qF1rZ4W5h4U32_(>fN=TZbnh;u0c$NwkB#Kbu1PiQ2Es>(AYWn@> zaUU~xc5M_?>O&jy?sHxJ~7}p$G`j4 z=j8i(f90`}vC{taayib(HCs1Mc`d)wT<}_3r@R%vRcrgr8b6jR^{ut#m3nLI>U?W! ztL?2^d7!pK8~_UwE1$wLoft{uWqRxq9cW4bILT+qYes-RNF;!D&p`{?gJX zsRdFCq!vgmkXj(MKx%>10;vU33;aK{KzrqE=SB4X9e6Li%y2fJgaDlPncwH|IRX!x z-)HezgXhg}KGMI`0;vU33#1lEEs$CuwLoft)B>pmQVXOONG*_B;J4HQm8w?kDhU8^ z|1U9sXMWFdo`xU7x8QO365I#3!@Hmcb1(~gVH2DOzue$BKY=IUKJeg1*a2t5k6-0D z55X~*gIU-GTi|^7`70?4pMl%p7~BFCcoV!HUU-G$oPuA%x8UROLHGdt8TjBq6|RE| z;KkpiJ@5@U4v)Z>;Q{yr+zNjRORyWV@cZz5#&LcIe-9smKL-yEz#PoNo8S#_0lXT{ zhg0X#R`>xt2zSGW;SOlQ4X_(F!6onq@Jjgib7?yqg&ScHTmb*^a>w}|9Ebbhub>Kl z2Tspyx!KxcHmuUt5veX(jeTs=hW$>X?Ox$-HXgD@ zwd$JOd0q8@d%y}DUh)^K8^_x;0wA&7JYxLSQ0yn%96_)4QUk?vL(n z)HP{Qs*>WW*H|m7t|3xjtk!Cmo3q{mFC!%vjAR~c9-Qcyp&`9v^b4&(mzFziPf5bm zx@he2v{zr0dbHVe1~Ynf61L!rOX*tEZ!CKa(=BF9M#|~&Q1{wfl1Bu!Af>R^YbT9~ z?WUW|U<~`5V#9vi&}RIEgU5)LPEW{gMF%4w+W(39*SE1(B8QxbM zzTO=zO-;}6??h>OpVVcBh?zrcuWs97tJ`VSBvqIJrmK)eURH?GB40AaBek|W+G#Av z8ZQZ5OPA?Wo?sL6!>m7gMyvU)Hh@S5=>$gm%v&al2gXV?R~gL->m9Dt>+V!>ax6#B zP_Vn#@|4a_`0b@y<6zd9Tv}0cGOE{jtUp=49IJk?g$ zv9zdVK2n19sxa5Au~B9_Ew6d4o0W25-_QGgU8}gqRr@+mgC3u;4l$0C@^X2uB8m?DbEhjVCnXlItTy+p}RGJ%EKDtL=sTFxhFN=6tW(v`HW0s@H zV2l;BWsDx-&}JKnNKX>!a3qN3QEHPc!IE189)Y7TX3^>(R| zl&`BHc5xJCZ1zx5Wo5HE(j=z1o6WI9ZFC!c+s!RDwz#=U-p$n*e(s{2jomh*EuYV4 z9aNw4{kCk>vYTefoE;F+k?zT<)O=4~&Z50pN$kzZp|Lk7iM=`1aiTY`O76`qjZBg( z$$3XFHeD^OG@I9ZM_aiXyHwECV!>g*=}k=QGh~=4&(Mw@5%&*qimv8NhP-3G=pHvB zM7|?yig`HT)}pp!H0VQ`**dzO*%O-S7RL-8^V1BB=<&>KoHoBxYAn<{Rapz^RNi0D zhAETmARG_7Qf0;NNtCwee8YodW1~~$ajMQ{Rl978W4F0&Dp~z<$}6%?4J1CozFaY?^BO_@#(wXd-BfDpZw%U9P$6fC)|Y(DgJ+rk5l;ZKY}OWt8g6d zhh=yhOhOrU!3OvRe*IVAA^02k2&_U4mS75Y!)0(5Jcplu3QoXN@Ev#%J_-%E5#9`w zP=@XBEPnq_;A`+D_#Av1?t%Bi66}Yo;f-)9ybfLqzrz3jHarSnfQR62I0o;45!eYA z!FTZa9|DO7?1Ssz3fKVO$Y2L}H(Uo-!DVm`{1d+Wz3?&UfcWzl!Fg~B|NUq11bi7D zhPy$0{5l+h{ctH<46lLz7M~tI3m0fGr)B>pme)ATPL$`8o$+D@d;Cqx{dZ zW&Mn^iJaZdMlHwDK<(~RxE$v8xN6_d1!1w6!>9a5v-!(u#T*3Vo?e${spMI?94h6s ztj|CaRuWevB1l)RPDtW*c8QYXiB*iyAwtP%94O_+>5zzYgFVS8?@DJBPnJh2UQ*;> zD%pZiU?9l&LUKU0RpkzOM+47!AWSxDni4A7O3qkBA|nU7Vr5~;hy*h za;zeQXcQ_E^?mjYPVXBZoa|{?aK`U997bv?kWpzKWgsNjMSKI(DLhuTQ9+7Gg{Nnu zc*B%2L4zj-Sp)~ctKocw#@t}@ob!8HAr@uBjV_^+{urJ4xJdA2^Mp3CCHL_%Zc z3dKghb`Z@ty#QITJlTnyc-?SDAr^6RD{f1L_t%Q5i2JSPFOd{ApR@_OVktWQD2pNa z&1x5HH!2+2KiH!+smplA*8QS8J$k6%;~=}4t~9Qs9_w97MsE#%O;tTEH3;xkTv3-m zfqY$MUi!^5*Ih-_f@qW|_iHMpdeW0S6df_^s|t}Yxd|EftL~04NU3&J6%mtrn4Hek zvty}iL*|LmF&5RCD2+vSzTko}913>)GT!wyBZBNV=|U^i#(7l8l9|Wsz}*kBs*q|| zSlfz8)@-O;9xDz`#Iy_UIg|9WvHw!*tzOd?edV)XyZ4U|6{p(mAeh*Lo}@|;W_dDZ^>|nkAExv{{SD);?w^lJOXz>8x~d(NB;YaW__yXJx?}o#02=>Dm48b5=39p9@ z@Zwp-2H<<}75H2DFdTzb=)fH8h0Ebw_yu?G{{j!fF{r?$@B;sFjUOp62YH$U@Pdo)Y4dQ8p-1#Z7_sB3eDfY%KEFQ%F zNTQK3(LA&9KdmoM&9PbkX8!WUrCj8C)X4E#Rn4(`3%;i#~xLVrQZiBu>=?>&~xkxrjsz15Qan_n9 z#hLw66Ks6aAa&jdX8_?>hBRA=oildtGIw=dzO2ZA}0An+=E>DN!7l@U&& z1R1-}R7StrvYu=qc-Gm0tZW?FfuMew^kxj(G)ANSns~O<7G#tKM_o#si2+T~nEkrM ztz$l$JJ=bqo=uY$q0lusB^oE3XY)oK8wgg*u(ku~QF{1{Dd{JAF%}(dgCq2?kKdFMUSH?2% zTgC%@-1B-;|EzW+Opp{PC8b5d7NbWZc8%2p^>pp3OqHOH&L=Nh)nLW>e=3hE0MdR&%?z82hUDXwR#LW|4>th9EFXqjty($3}T0 zCi-}1u!@A^*l4cfZbn(grn)5OwIQ1l3yDi3y6w4ED|W`Cyi!`pQ=7E>3ddHo_lSPj z>bq-`VH4{;BT@I4DAyZC)N?1WhY@YV0Na)Se?2~~kKZf){|F!dihqAMv|t#9;2L-i zpI+|z<&OU*xEy|fFMlumHPqn%6yS1r13ZmCFL(6wa3P$)kN+$zLKeP{@BTQ5Uwy`;eW8jakvwdUBs4BxHF8Z zBuF^Jpi2M91uMrIF_knp%j;(Ns?r12+qE|y>vUp}Jr)}aQco|)9%K)N^o@>rl4q?e xifFi^D>A|;hy~96uY)o31n@6%q+Kn)#xPGikntd_hF`J~x_rHbqV6p%J literal 0 HcmV?d00001 diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs index 73ccc70c..0fc5a1c7 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -158,9 +158,9 @@ Function Evaluate(objCode, objEnv) Evaluate.Type = TYPE_LAMBDA Set Evaluate.Value = New Lambda 'MsgBox 1 - 'Set Evaluate.Value.objEnv = New Environment - 'Evaluate.Value.objEnv.SetSelf Evaluate.Value.objEnv - 'Evaluate.Value.objEnv.SetOuter objEnv + Set Evaluate.Value.objEnv = New Environment + Evaluate.Value.objEnv.SetSelf Evaluate.Value.objEnv + Evaluate.Value.objEnv.SetOuter objEnv Set Evaluate.Value.objParameters = objCode.Value.Item(1) Set Evaluate.Value.objBody = objCode.Value.Item(2) 'MsgBox 1 @@ -177,9 +177,11 @@ Function Evaluate(objCode, objEnv) 'ÕâÀïÓдóÎÊÌâ If objSymbol.Value.IsBuiltIn Then - Set objSymbol.Value.objEnv = New Environment + dim oldenv + set oldenv = objSymbol.Value.objEnv + Set objSymbol.Value.objEnv = objEnv objSymbol.Value.objEnv.SetSelf objSymbol.Value.objEnv - objSymbol.Value.objEnv.SetOuter objEnv + objSymbol.Value.objEnv.SetOuter oldEnv Set Evaluate = objSymbol.Value.Run(objCode) Else From 38f8a957ba189ef74202a20bad80e9741b777cca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E8=80=81=E5=88=98?= <632171029@qq.com> Date: Fri, 23 Dec 2022 23:40:24 +0800 Subject: [PATCH 19/44] rewrite codes --- impls/vbs/.step4_if_fn_do.vbs.swp | Bin 24576 -> 0 bytes impls/vbs/core.vbs | 149 ++++++++++++-- impls/vbs/printer.vbs | 77 ++++---- impls/vbs/reader.vbs | 311 ++++++++++++++++-------------- impls/vbs/step1_read_print.vbs | 19 +- 5 files changed, 356 insertions(+), 200 deletions(-) delete mode 100644 impls/vbs/.step4_if_fn_do.vbs.swp diff --git a/impls/vbs/.step4_if_fn_do.vbs.swp b/impls/vbs/.step4_if_fn_do.vbs.swp deleted file mode 100644 index 12430fdb5ea61e6e5578d783524559f9a220f618..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 24576 zcmeI33yfS>d4MlXLNW#1kc3Eu2CgTGJ!3ZGS869|9kP#Edz9Us&F*>^P{Enqx$B*H zcJ4BdwH>uU8>0qF1rZ4W5h4U32_(>fN=TZbnh;u0c$NwkB#Kbu1PiQ2Es>(AYWn@> zaUU~xc5M_?>O&jy?sHxJ~7}p$G`j4 z=j8i(f90`}vC{taayib(HCs1Mc`d)wT<}_3r@R%vRcrgr8b6jR^{ut#m3nLI>U?W! ztL?2^d7!pK8~_UwE1$wLoft{uWqRxq9cW4bILT+qYes-RNF;!D&p`{?gJX zsRdFCq!vgmkXj(MKx%>10;vU33;aK{KzrqE=SB4X9e6Li%y2fJgaDlPncwH|IRX!x z-)HezgXhg}KGMI`0;vU33#1lEEs$CuwLoft)B>pmQVXOONG*_B;J4HQm8w?kDhU8^ z|1U9sXMWFdo`xU7x8QO365I#3!@Hmcb1(~gVH2DOzue$BKY=IUKJeg1*a2t5k6-0D z55X~*gIU-GTi|^7`70?4pMl%p7~BFCcoV!HUU-G$oPuA%x8UROLHGdt8TjBq6|RE| z;KkpiJ@5@U4v)Z>;Q{yr+zNjRORyWV@cZz5#&LcIe-9smKL-yEz#PoNo8S#_0lXT{ zhg0X#R`>xt2zSGW;SOlQ4X_(F!6onq@Jjgib7?yqg&ScHTmb*^a>w}|9Ebbhub>Kl z2Tspyx!KxcHmuUt5veX(jeTs=hW$>X?Ox$-HXgD@ zwd$JOd0q8@d%y}DUh)^K8^_x;0wA&7JYxLSQ0yn%96_)4QUk?vL(n z)HP{Qs*>WW*H|m7t|3xjtk!Cmo3q{mFC!%vjAR~c9-Qcyp&`9v^b4&(mzFziPf5bm zx@he2v{zr0dbHVe1~Ynf61L!rOX*tEZ!CKa(=BF9M#|~&Q1{wfl1Bu!Af>R^YbT9~ z?WUW|U<~`5V#9vi&}RIEgU5)LPEW{gMF%4w+W(39*SE1(B8QxbM zzTO=zO-;}6??h>OpVVcBh?zrcuWs97tJ`VSBvqIJrmK)eURH?GB40AaBek|W+G#Av z8ZQZ5OPA?Wo?sL6!>m7gMyvU)Hh@S5=>$gm%v&al2gXV?R~gL->m9Dt>+V!>ax6#B zP_Vn#@|4a_`0b@y<6zd9Tv}0cGOE{jtUp=49IJk?g$ zv9zdVK2n19sxa5Au~B9_Ew6d4o0W25-_QGgU8}gqRr@+mgC3u;4l$0C@^X2uB8m?DbEhjVCnXlItTy+p}RGJ%EKDtL=sTFxhFN=6tW(v`HW0s@H zV2l;BWsDx-&}JKnNKX>!a3qN3QEHPc!IE189)Y7TX3^>(R| zl&`BHc5xJCZ1zx5Wo5HE(j=z1o6WI9ZFC!c+s!RDwz#=U-p$n*e(s{2jomh*EuYV4 z9aNw4{kCk>vYTefoE;F+k?zT<)O=4~&Z50pN$kzZp|Lk7iM=`1aiTY`O76`qjZBg( z$$3XFHeD^OG@I9ZM_aiXyHwECV!>g*=}k=QGh~=4&(Mw@5%&*qimv8NhP-3G=pHvB zM7|?yig`HT)}pp!H0VQ`**dzO*%O-S7RL-8^V1BB=<&>KoHoBxYAn<{Rapz^RNi0D zhAETmARG_7Qf0;NNtCwee8YodW1~~$ajMQ{Rl978W4F0&Dp~z<$}6%?4J1CozFaY?^BO_@#(wXd-BfDpZw%U9P$6fC)|Y(DgJ+rk5l;ZKY}OWt8g6d zhh=yhOhOrU!3OvRe*IVAA^02k2&_U4mS75Y!)0(5Jcplu3QoXN@Ev#%J_-%E5#9`w zP=@XBEPnq_;A`+D_#Av1?t%Bi66}Yo;f-)9ybfLqzrz3jHarSnfQR62I0o;45!eYA z!FTZa9|DO7?1Ssz3fKVO$Y2L}H(Uo-!DVm`{1d+Wz3?&UfcWzl!Fg~B|NUq11bi7D zhPy$0{5l+h{ctH<46lLz7M~tI3m0fGr)B>pme)ATPL$`8o$+D@d;Cqx{dZ zW&Mn^iJaZdMlHwDK<(~RxE$v8xN6_d1!1w6!>9a5v-!(u#T*3Vo?e${spMI?94h6s ztj|CaRuWevB1l)RPDtW*c8QYXiB*iyAwtP%94O_+>5zzYgFVS8?@DJBPnJh2UQ*;> zD%pZiU?9l&LUKU0RpkzOM+47!AWSxDni4A7O3qkBA|nU7Vr5~;hy*h za;zeQXcQ_E^?mjYPVXBZoa|{?aK`U997bv?kWpzKWgsNjMSKI(DLhuTQ9+7Gg{Nnu zc*B%2L4zj-Sp)~ctKocw#@t}@ob!8HAr@uBjV_^+{urJ4xJdA2^Mp3CCHL_%Zc z3dKghb`Z@ty#QITJlTnyc-?SDAr^6RD{f1L_t%Q5i2JSPFOd{ApR@_OVktWQD2pNa z&1x5HH!2+2KiH!+smplA*8QS8J$k6%;~=}4t~9Qs9_w97MsE#%O;tTEH3;xkTv3-m zfqY$MUi!^5*Ih-_f@qW|_iHMpdeW0S6df_^s|t}Yxd|EftL~04NU3&J6%mtrn4Hek zvty}iL*|LmF&5RCD2+vSzTko}913>)GT!wyBZBNV=|U^i#(7l8l9|Wsz}*kBs*q|| zSlfz8)@-O;9xDz`#Iy_UIg|9WvHw!*tzOd?edV)XyZ4U|6{p(mAeh*Lo}@|;W_dDZ^>|nkAExv{{SD);?w^lJOXz>8x~d(NB;YaW__yXJx?}o#02=>Dm48b5=39p9@ z@Zwp-2H<<}75H2DFdTzb=)fH8h0Ebw_yu?G{{j!fF{r?$@B;sFjUOp62YH$U@Pdo)Y4dQ8p-1#Z7_sB3eDfY%KEFQ%F zNTQK3(LA&9KdmoM&9PbkX8!WUrCj8C)X4E#Rn4(`3%;i#~xLVrQZiBu>=?>&~xkxrjsz15Qan_n9 z#hLw66Ks6aAa&jdX8_?>hBRA=oildtGIw=dzO2ZA}0An+=E>DN!7l@U&& z1R1-}R7StrvYu=qc-Gm0tZW?FfuMew^kxj(G)ANSns~O<7G#tKM_o#si2+T~nEkrM ztz$l$JJ=bqo=uY$q0lusB^oE3XY)oK8wgg*u(ku~QF{1{Dd{JAF%}(dgCq2?kKdFMUSH?2% zTgC%@-1B-;|EzW+Opp{PC8b5d7NbWZc8%2p^>pp3OqHOH&L=Nh)nLW>e=3hE0MdR&%?z82hUDXwR#LW|4>th9EFXqjty($3}T0 zCi-}1u!@A^*l4cfZbn(grn)5OwIQ1l3yDi3y6w4ED|W`Cyi!`pQ=7E>3ddHo_lSPj z>bq-`VH4{;BT@I4DAyZC)N?1WhY@YV0Na)Se?2~~kKZf){|F!dihqAMv|t#9;2L-i zpI+|z<&OU*xEy|fFMlumHPqn%6yS1r13ZmCFL(6wa3P$)kN+$zLKeP{@BTQ5Uwy`;eW8jakvwdUBs4BxHF8Z zBuF^Jpi2M91uMrIF_knp%j;(Ns?r12+qE|y>vUp}Jr)}aQco|)9%K)N^o@>rl4q?e xifFi^D>A|;hy~96uY)o31n@6%q+Kn)#xPGikntd_hF`J~x_rHbqV6p%J diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index 3bbb5124..0aa22908 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -1,21 +1,144 @@ -Const TYPE_LIST = 0 -Const TYPE_VECTOR = 1 -Const TYPE_HASHMAP = 2 -Const TYPE_BOOLEAN = 3 -Const TYPE_NIL = 4 -Const TYPE_KEYWORD = 5 -Const TYPE_STRING = 6 -Const TYPE_NUMBER = 7 -Const TYPE_SYMBOL = 8 -Const TYPE_FUNCTION = 9 -Const TYPE_LAMBDA = 9 -Const TYPE_SPECIAL = 10 +Option Explicit + +Dim TYPES +Set TYPES = New MalTypes +Class MalTypes + Public LIST, VECTOR, HASHMAP, [BOOLEAN], NIL + Public KEYWORD, [STRING], NUMBER, SYMBOL + Public LAMBDA, PROCEDURE + + Public [TypeName] + Private Sub Class_Initialize + [TypeName] = Array( _ + "LIST", "VECTOR", "HASHMAP", "BOOLEAN", _ + "NIL", "KEYWORD", "STRING", "NUMBER", _ + "SYMBOL", "LAMBDA", "PROCEDURE") + + Dim i + For i = 0 To UBound([TypeName]) + Execute "[" + [TypeName](i) + "] = " + CStr(i+10) + Next + End Sub +End Class Class MalType Public [Type] Public Value End Class +Function NewMalType(lngType, varValue) + Dim varResult + Set varResult = New MalType + With varResult + .Type = lngType + .Value = Wrap(varValue) + End With + Set NewMalType = varResult +End Function + +Function Wrap(varValue) + Wrap = Array(varValue) +End Function + +Function Unwrap(varValue) + If IsObject(varValue(0)) Then + Set Unwrap = varValue(0) + Else + Unwrap = varValue(0) + End If +End Function + +Function ValueOf(objMalType) + If IsObject(Unwrap(objMalType.Value)) Then + Set ValueOf = Unwrap(objMalType.Value) + Else + ValueOf = Unwrap(objMalType.Value) + End If +End Function + +Class MalList + Public [Type] + Public Value + + Public Function Add(objMalType) + Unwrap(Value).Add objMalType + End Function + + Public Function Item(i) + Set Item = Unwrap(Value).Item(i) + End Function + + Public Function Count() + Count = Unwrap(Value).Count + End Function +End Class + +Function NewMalList(arrValues) + Dim varResult + Set varResult = New MalList + With varResult + .Type = TYPES.LIST + .Value = Wrap(CreateObject("System.Collections.ArrayList")) + + Dim i + For i = 0 To UBound(arrValues) + .Add arrValues(i) + Next + End With + Set NewMalList = varResult +End Function + +Function NewMalVector(arrValues) + Dim varResult + Set varResult = New MalList + With varResult + .Type = TYPES.VECTOR + .Value = Wrap(CreateObject("System.Collections.ArrayList")) + + Dim i + For i = 0 To UBound(arrValues) + .Add arrValues(i) + Next + End With + Set NewMalVector = varResult +End Function + +Class MalHashmap + Public [Type] + Public Value + + Public Function Add(varKey, varValue) + Unwrap(Value).Add varKey, varValue + End Function + + Public Property Get Keys() + Keys = Unwrap(Value).Keys + End Property + + Public Function Count() + Count = Unwrap(Value).Count + End Function + + Public Function Item(varKey) + Set Item = Unwrap(Value).Item(varKey) + End Function +End Class + +Function NewMalHashmap(arrKeys, arrValues) + Dim varResult + Set varResult = New MalHashmap + With varResult + .Type = TYPES.HASHMAP + .Value = Wrap(CreateObject("Scripting.Dictionary")) + + Dim i + For i = 0 To UBound(arrKeys) + .Add arrKeys(i), arrValues(i) + Next + End With + Set NewMalHashmap = varResult +End Function + Public objCoreNS Set objCoreNS = CreateObject("Scripting.Dictionary") objCoreNS.Add "+", GetRef("Add") @@ -284,4 +407,4 @@ Function Divide(objArgs) Set Divide = New MalType Divide.Type = TYPE_NUMBER Divide.Value = objArgs.Value.Item(1).Value \ objArgs.Value.Item(2).Value -End Function \ No newline at end of file +End Function diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs index e99f0e30..27e9268a 100644 --- a/impls/vbs/printer.vbs +++ b/impls/vbs/printer.vbs @@ -1,76 +1,87 @@ Option Explicit Function PrintMalType(objMal, boolReadable) - 'MsgBox 1 - PrintMalType = "" + Dim varResult + + varResult = "" + If TypeName(objMal) = "Nothing" Then + PrintMalType = "" Exit Function End If Dim i Select Case objMal.Type - Case TYPE_LIST - With objMal.Value + Case TYPES.LIST + With ValueOf(objMal) For i = 0 To .Count - 2 - PrintMalType = PrintMalType & _ + varResult = varResult & _ PrintMalType(.Item(i), boolReadable) & " " Next If .Count > 0 Then - PrintMalType = PrintMalType & _ + varResult = varResult & _ PrintMalType(.Item(.Count - 1), boolReadable) End If End With - PrintMalType = "(" & PrintMalType & ")" - Case TYPE_VECTOR - With objMal.Value + varResult = "(" & varResult & ")" + Case TYPES.VECTOR + With ValueOf(objMal) For i = 0 To .Count - 2 - PrintMalType = PrintMalType & _ + varResult = varResult & _ PrintMalType(.Item(i), boolReadable) & " " Next If .Count > 0 Then - PrintMalType = PrintMalType & _ + varResult = varResult & _ PrintMalType(.Item(.Count - 1), boolReadable) End If End With - PrintMalType = "[" & PrintMalType & "]" - Case TYPE_HASHMAP - With objMal.Value + varResult = "[" & varResult & "]" + Case TYPES.HASHMAP + With ValueOf(objMal) Dim arrKeys arrKeys = .Keys For i = 0 To .Count - 2 - PrintMalType = PrintMalType & _ + varResult = varResult & _ PrintMalType(arrKeys(i), boolReadable) & " " & _ PrintMalType(.Item(arrKeys(i)), boolReadable) & " " Next If .Count > 0 Then - PrintMalType = PrintMalType & _ + varResult = varResult & _ PrintMalType(arrKeys(.Count - 1), boolReadable) & " " & _ PrintMalType(.Item(arrKeys(.Count - 1)), boolReadable) End If End With - PrintMalType = "{" & PrintMalType & "}" - Case TYPE_STRING + varResult = "{" & varResult & "}" + Case TYPES.STRING If boolReadable Then - PrintMalType = EscapeString(objMal.Value) + varResult = EscapeString(ValueOf(objMal)) Else - 'PrintMalType = """" & objMal.Value & """" - PrintMalType = objMal.Value + varResult = ValueOf(objMal) End If - Case TYPE_BOOLEAN - If objMal.Value Then - PrintMalType = "true" + Case TYPES.BOOLEAN + If ValueOf(objMal) Then + varResult = "true" Else - PrintMalType = "false" + varResult = "false" End If - Case TYPE_NIL - PrintMalType = "nil" - Case TYPE_NUMBER - PrintMalType = CStr(objMal.Value) - Case TYPE_FUNCTION - PrintMalType = "#" + Case TYPES.NIL + varResult = "nil" + Case TYPES.NUMBER + varResult = CStr(ValueOf(objMal)) + Case TYPES.LAMBDA + varResult = "#" + Case TYPES.PROCEDURE + varResult = "#" + Case TYPES.KEYWORD + varResult = ValueOf(objMal) + Case TYPES.SYMBOL + varResult = ValueOf(objMal) Case Else - PrintMalType = objMal.Value + Err.Raise vbObjectError, _ + "PrintMalType", "unknown type" End Select + + PrintMalType = varResult End Function Function EscapeString(strRaw) @@ -79,4 +90,4 @@ Function EscapeString(strRaw) EscapeString = Replace(EscapeString, vbCrLf, "\n") EscapeString = Replace(EscapeString, """", "\""") EscapeString = """" & EscapeString & """" -End Function \ No newline at end of file +End Function diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index 2902a451..e9f69348 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -4,229 +4,249 @@ Function ReadString(strCode) Set ReadString = ReadForm(Tokenize(strCode)) End Function -Function Tokenize(strCode) - Dim objRE - Set objRE = New RegExp - With objRE - .Pattern = "[\s,]*(~@|[\[\]{}()'`~^@]|""(?:\\.|[^\\""])*""?|;.*|[^\s\[\]{}('""`,;)]*)" - .IgnoreCase = True - .Global = True - End With +Class Tokens + Private strRaw, objTokens + Private objRE - Dim objTokens, objMatches, objMatch - Set objTokens = CreateObject("System.Collections.Queue") - Set objMatches = objRE.Execute(strCode) - Dim strToken - For Each objMatch In objMatches - strToken = objMatch.SubMatches(0) - If Not Left(strToken, 1) = ";" Then - objTokens.Enqueue strToken - End If - Next + Private Sub Class_Initialize + Set objRE = New RegExp + With objRE + .Pattern = "[\s,]*(~@|[\[\]{}()'`~^@]|""(?:\\.|[^\\""])*""?|;.*|[^\s\[\]{}('""`,;)]*)" + .IgnoreCase = True + .Global = True + End With - Set Tokenize = objTokens + Set objTokens = CreateObject("System.Collections.Queue") + End Sub + + Public Function Init(strCode) + strRaw = 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 + ' Drop comments + objTokens.Enqueue Trim(strToken) + End If + Next + End Function + + Public Function Current() + Current = objTokens.Peek() + End Function + + Public Function MoveToNext() + MoveToNext = objTokens.Dequeue() + End Function + + Public Function AtEnd() + AtEnd = (objTokens.Count = 0) + End Function + + Public Function Count() + Count = objTokens.Count + End Function +End Class + +Function Tokenize(strCode) ' Return objTokens + Dim varResult + Set varResult = New Tokens + varResult.Init strCode + Set Tokenize = varResult End Function -Public boolError, strError - -Function ReadForm(objTokens) - If objTokens.Count = 0 Then - Set ReadForm = Nothing - Exit Function - End If - - If objTokens.Count = 1 And objTokens.Peek() = "" Then - Call objTokens.Dequeue() +Function ReadForm(objTokens) ' Return Nothing / MalType + If objTokens.AtEnd() Then Set ReadForm = Nothing Exit Function End If Dim strToken - strToken = objTokens.Peek() + strToken = objTokens.Current() + Dim varResult If InStr("([{", strToken) Then Select Case strToken Case "(" - Set ReadForm = ReadList(objTokens) + Set varResult = ReadList(objTokens) Case "[" - Set ReadForm = ReadVector(objTokens) + Set varResult = ReadVector(objTokens) Case "{" - Set ReadForm = ReadHashmap(objTokens) + Set varResult = ReadHashmap(objTokens) End Select ElseIf InStr("'`~@", strToken) Then - Call objTokens.Dequeue() - - Dim strAlias - Select Case strToken - Case "'" - strAlias = "quote" - Case "`" - strAlias = "quasiquote" - Case "~" - strAlias = "unquote" - Case "~@" - strAlias = "splice-unquote" - Case "@" - strAlias = "deref" - Case Else - boolError = True - strError = "unknown token " & strAlias - Call REPL() - End Select - - Set ReadForm = New MalType - ReadForm.Type = TYPE_LIST - Set ReadForm.Value = CreateObject("System.Collections.ArrayList") - ReadForm.Value.Add New MalType - ReadForm.Value.Item(0).Type = TYPE_SYMBOL - ReadForm.Value.Item(0).Value = strAlias - ReadForm.Value.Add ReadForm(objTokens) + Set varResult = ReadSpecial(objTokens) ElseIf InStr(")]}", strToken) Then - Call objTokens.Dequeue() - - boolError = True - strError = "unbalanced parentheses" - Call REPL() + Err.Raise vbObjectError, _ + "ReadForm", "unbalanced parentheses" ElseIf strToken = "^" Then - Call objTokens.Dequeue() - Set ReadForm = New MalType - ReadForm.Type = TYPE_LIST - Set ReadForm.Value = CreateObject("System.Collections.ArrayList") - ReadForm.Value.Add New MalType - ReadForm.Value.Item(0).Type = TYPE_SYMBOL - ReadForm.Value.Item(0).Value = "with-meta" - Dim objTemp - Set objTemp = ReadForm(objTokens) - ReadForm.Value.Add ReadForm(objTokens) - ReadForm.Value.Add objTemp + Set varResult = ReadMetadata(objTokens) Else - Set ReadForm = ReadAtom(objTokens) + Set varResult = ReadAtom(objTokens) End If + + If Not objTokens.AtEnd() Then + 'Err.Raise vbObjectError, _ + ' "ReadForm", "extra token(s): " + objTokens.Current() + End If + + Set ReadForm = varResult +End Function + +Function ReadMetadata(objTokens) + Dim varResult + + Call objTokens.MoveToNext() + Dim objTmp + Set objTmp = ReadForm(objTokens) + Set varResult = NewMalList(Array( _ + NewMalType(TYPES.SYMBOL, "with-meta"), _ + ReadForm(objTokens), objTmp)) + + 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( _ + NewMalType(TYPES.SYMBOL, strAlias), _ + ReadForm(objTokens))) + Set ReadSpecial = varResult End Function Function ReadList(objTokens) - Call objTokens.Dequeue() + Dim varResult + Call objTokens.MoveToNext() - If objTokens.Count = 0 Then - boolError = True - strError = "unbalanced parentheses" - Call REPL() + If objTokens.AtEnd() Then + Err.Raise vbObjectError, _ + "ReadList", "unbalanced parentheses" End If - Set ReadList = New MalType - Set ReadList.Value = CreateObject("System.Collections.ArrayList") - ReadList.Type = TYPE_LIST - - With ReadList.Value - While objTokens.Count > 1 And objTokens.Peek() <> ")" + Set varResult = NewMalList(Array()) + With varResult + While objTokens.Count() > 1 And objTokens.Current() <> ")" .Add ReadForm(objTokens) Wend End With - If objTokens.Dequeue() <> ")" Then - boolError = True - strError = "unbalanced parentheses" - Call REPL() + If objTokens.MoveToNext() <> ")" Then + Err.Raise vbObjectError, _ + "ReadList", "unbalanced parentheses" End If + + Set ReadList = varResult End Function -function ReadVector(objTokens) - Call objTokens.Dequeue() +Function ReadVector(objTokens) + Dim varResult + Call objTokens.MoveToNext() - If objTokens.Count = 0 Then - boolError = True - strError = "unbalanced parentheses" - Call REPL() + If objTokens.AtEnd() Then + Err.Raise vbObjectError, _ + "ReadVector", "unbalanced parentheses" End If - Set ReadVector = New MalType - Set ReadVector.Value = CreateObject("System.Collections.ArrayList") - ReadVector.Type = TYPE_VECTOR - - With ReadVector.Value - While objTokens.Count > 1 And objTokens.Peek() <> "]" + Set varResult = NewMalVector(Array()) + With varResult + While objTokens.Count() > 1 And objTokens.Current() <> "]" .Add ReadForm(objTokens) Wend End With - If objTokens.Dequeue() <> "]" Then - boolError = True - strError = "unbalanced parentheses" - Call REPL() + If objTokens.MoveToNext() <> "]" Then + Err.Raise vbObjectError, _ + "ReadVector", "unbalanced parentheses" End If + + Set ReadVector = varResult End Function Function ReadHashmap(objTokens) - Call objTokens.Dequeue() + Dim varResult + Call objTokens.MoveToNext() If objTokens.Count = 0 Then - boolError = True - strError = "unbalanced parentheses" - Call REPL() + Err.Raise vbObjectError, _ + "ReadHashmap", "unbalanced parentheses" End If - - Set ReadHashmap = New MalType - Set ReadHashmap.Value = CreateObject("Scripting.Dictionary") - ReadHashmap.Type = TYPE_HASHMAP + Set varResult = NewMalHashmap(Array(), Array()) Dim objKey, objValue - With ReadHashmap.Value - While objTokens.Count > 2 And objTokens.Peek() <> "}" + 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.Dequeue() <> "}" Then - boolError = True - strError = "unbalanced parentheses" - Call REPL() + If objTokens.MoveToNext() <> "}" Then + Err.Raise vbObjectError, _ + "ReadHashmap", "unbalanced parentheses" End If + + Set ReadHashmap = varResult End Function Function ReadAtom(objTokens) - Dim strAtom - strAtom = objTokens.Dequeue() + Dim varResult + + Dim strAtom + strAtom = objTokens.MoveToNext() - Dim objAtom - Set objAtom = New MalType Select Case strAtom Case "true" - objAtom.Type = TYPE_BOOLEAN - objAtom.Value = True + Set varResult = NewMalType(TYPES.BOOLEAN, True) Case "false" - objAtom.Type = TYPE_BOOLEAN - objAtom.Value = False + Set varResult = NewMalType(TYPES.BOOLEAN, False) Case "nil" - objAtom.Type = TYPE_NIL + Set varResult = NewMalType(TYPES.NIL, Empty) Case Else Select Case Left(strAtom, 1) Case ":" - objAtom.Type = TYPE_KEYWORD - objAtom.Value = strAtom + Set varResult = NewMalType(TYPES.KEYWORD, strAtom) Case """" - objAtom.Type = TYPE_STRING - objAtom.Value = ParseString(strAtom) + Set varResult = NewMalType(TYPES.STRING, ParseString(strAtom)) Case Else If IsNumeric(strAtom) Then - objAtom.Type = TYPE_NUMBER - objAtom.Value = Eval(strAtom) + Set varResult = NewMalType(TYPES.NUMBER, Eval(strAtom)) Else - objAtom.Type = TYPE_SYMBOL - objAtom.Value = strAtom + Set varResult = NewMalType(TYPES.SYMBOL, strAtom) End If End Select End Select - Set ReadAtom = objAtom + Set ReadAtom = varResult End Function Function ParseString(strRaw) If Right(strRaw, 1) <> """" Or Len(strRaw) < 2 Then - boolError = True - strError = "unterminated string, got EOF" - Call REPL() + Err.Raise vbObjectError, _ + "ParseString", "unterminated string, got EOF" End If Dim strTemp @@ -254,9 +274,8 @@ Function ParseString(strRaw) If Right(strTemp, 1) <> "\" Then ParseString = ParseString & Right(strTemp, 1) Else - boolError = True - strError = "unterminated string, got EOF" - Call REPL() + Err.Raise vbObjectError, _ + "ParseString", "unterminated string, got EOF" End If End If End Function diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs index 3dd09014..5570663a 100644 --- a/impls/vbs/step1_read_print.vbs +++ b/impls/vbs/step1_read_print.vbs @@ -9,16 +9,19 @@ Call REPL() Sub REPL() Dim strCode, strResult While True - If boolError Then - WScript.StdErr.WriteLine "ERROR: " & strError - boolError = False - End If WScript.StdOut.Write("user> ") + On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + On Error Resume Next + WScript.Echo REP(strCode) + If Err.Number <> 0 Then + WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + End If On Error Goto 0 - WScript.Echo REP(strCode) Wend End Sub @@ -45,4 +48,4 @@ Sub Include(strFileName) .GetFile(WScript.ScriptFullName)) & _ "\" & strFileName).ReadAll End With -End Sub \ No newline at end of file +End Sub From ef7e9c4ad43efd7dbc8c13001bc4a615ab12e42e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E8=80=81=E5=88=98?= <632171029@qq.com> Date: Thu, 19 Jan 2023 16:13:48 +0800 Subject: [PATCH 20/44] rewrite step0 & 1 --- impls/vbs/step0_repl.vbs | 5 +++-- impls/vbs/step1_read_print.vbs | 4 ++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/impls/vbs/step0_repl.vbs b/impls/vbs/step0_repl.vbs index 862e690e..c965e395 100644 --- a/impls/vbs/step0_repl.vbs +++ b/impls/vbs/step0_repl.vbs @@ -20,8 +20,9 @@ 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 + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 + WScript.Echo REP(strCode) Wend diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs index 5570663a..454042bb 100644 --- a/impls/vbs/step1_read_print.vbs +++ b/impls/vbs/step1_read_print.vbs @@ -7,7 +7,7 @@ Include "Printer.vbs" Call REPL() Sub REPL() - Dim strCode, strResult + Dim strCode While True WScript.StdOut.Write("user> ") @@ -48,4 +48,4 @@ Sub Include(strFileName) .GetFile(WScript.ScriptFullName)) & _ "\" & strFileName).ReadAll End With -End Sub +End Sub \ No newline at end of file From 5427d9da9232b5af453df19f2e17b9d1c5ad4620 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E8=80=81=E5=88=98?= <632171029@qq.com> Date: Thu, 19 Jan 2023 19:27:04 +0800 Subject: [PATCH 21/44] new file 'types.vbs' & fix bugs & rewrite --- impls/vbs/core.vbs | 669 +++++++++++++-------------------- impls/vbs/install.vbs | 3 + impls/vbs/printer.vbs | 18 +- impls/vbs/reader.vbs | 94 ++--- impls/vbs/step1_read_print.vbs | 2 +- impls/vbs/types.vbs | 249 ++++++++++++ 6 files changed, 582 insertions(+), 453 deletions(-) create mode 100644 impls/vbs/install.vbs create mode 100644 impls/vbs/types.vbs diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index 0aa22908..15512e2d 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -1,410 +1,281 @@ -Option Explicit +Include "Types.vbs" -Dim TYPES -Set TYPES = New MalTypes -Class MalTypes - Public LIST, VECTOR, HASHMAP, [BOOLEAN], NIL - Public KEYWORD, [STRING], NUMBER, SYMBOL - Public LAMBDA, PROCEDURE - - Public [TypeName] - Private Sub Class_Initialize - [TypeName] = Array( _ - "LIST", "VECTOR", "HASHMAP", "BOOLEAN", _ - "NIL", "KEYWORD", "STRING", "NUMBER", _ - "SYMBOL", "LAMBDA", "PROCEDURE") - - Dim i - For i = 0 To UBound([TypeName]) - Execute "[" + [TypeName](i) + "] = " + CStr(i+10) - Next - End Sub -End Class - -Class MalType - Public [Type] - Public Value -End Class - -Function NewMalType(lngType, varValue) - Dim varResult - Set varResult = New MalType - With varResult - .Type = lngType - .Value = Wrap(varValue) +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll End With - Set NewMalType = varResult -End Function - -Function Wrap(varValue) - Wrap = Array(varValue) -End Function - -Function Unwrap(varValue) - If IsObject(varValue(0)) Then - Set Unwrap = varValue(0) - Else - Unwrap = varValue(0) - End If -End Function - -Function ValueOf(objMalType) - If IsObject(Unwrap(objMalType.Value)) Then - Set ValueOf = Unwrap(objMalType.Value) - Else - ValueOf = Unwrap(objMalType.Value) - End If -End Function - -Class MalList - Public [Type] - Public Value - - Public Function Add(objMalType) - Unwrap(Value).Add objMalType - End Function - - Public Function Item(i) - Set Item = Unwrap(Value).Item(i) - End Function - - Public Function Count() - Count = Unwrap(Value).Count - End Function -End Class - -Function NewMalList(arrValues) - Dim varResult - Set varResult = New MalList - With varResult - .Type = TYPES.LIST - .Value = Wrap(CreateObject("System.Collections.ArrayList")) - - Dim i - For i = 0 To UBound(arrValues) - .Add arrValues(i) - Next - End With - Set NewMalList = varResult -End Function - -Function NewMalVector(arrValues) - Dim varResult - Set varResult = New MalList - With varResult - .Type = TYPES.VECTOR - .Value = Wrap(CreateObject("System.Collections.ArrayList")) - - Dim i - For i = 0 To UBound(arrValues) - .Add arrValues(i) - Next - End With - Set NewMalVector = varResult -End Function - -Class MalHashmap - Public [Type] - Public Value - - Public Function Add(varKey, varValue) - Unwrap(Value).Add varKey, varValue - End Function - - Public Property Get Keys() - Keys = Unwrap(Value).Keys - End Property - - Public Function Count() - Count = Unwrap(Value).Count - End Function - - Public Function Item(varKey) - Set Item = Unwrap(Value).Item(varKey) - End Function -End Class - -Function NewMalHashmap(arrKeys, arrValues) - Dim varResult - Set varResult = New MalHashmap - With varResult - .Type = TYPES.HASHMAP - .Value = Wrap(CreateObject("Scripting.Dictionary")) - - Dim i - For i = 0 To UBound(arrKeys) - .Add arrKeys(i), arrValues(i) - Next - End With - Set NewMalHashmap = varResult -End Function - -Public objCoreNS -Set objCoreNS = CreateObject("Scripting.Dictionary") -objCoreNS.Add "+", GetRef("Add") -objCoreNS.Add "-", GetRef("Subtract") -objCoreNS.Add "*", GetRef("Multiply") -objCoreNS.Add "/", GetRef("Divide") -objCoreNS.Add "list", GetRef("mMakeList") -objCoreNS.Add "list?", GetRef("mIsList") '1 -objCoreNS.Add "empty?", GetRef("mIsListEmpty") '1 -objCoreNS.Add "count", GetRef("mListCount") '1 -objCoreNS.Add "=", GetRef("mEqual") '2 'both type & value -objCoreNS.Add "<", GetRef("mLess") '2 'number only -objCoreNS.Add ">", GetRef("mGreater") '2 'number only -objCoreNS.Add "<=", GetRef("mEqualLess") '2 'number only -objCoreNS.Add ">=", GetRef("mEqualGreater") '2 'number only -objCoreNS.Add "pr-str", GetRef("mprstr") 'all 'ret str 'readable 'concat by space -objCoreNS.Add "str", GetRef("mstr") 'all 'ret str '!readable 'concat by "" -objCoreNS.Add "prn", GetRef("mprn") 'all 'to screen ret nil 'concat by space 'readable -objCoreNS.Add "println", GetRef("mprintln") 'all 'to screen ret nil 'concat by space '!readable -objCoreNS.Add "get", GetRef("mGet") -objCoreNS.Add "set", GetRef("mSet") -objCoreNS.Add "first", GetRef("mFirst") -objCoreNS.Add "last", GetRef("mLast") - -Function mLast(objArgs) - Set objRes = New MalType - objRes.Type = TYPE_LIST - set objRes.value = createobject("system.collections.arraylist") - for i = 1 to objArgs.value.item(1).value.count - 1 - objRes.value.add objArgs.value.item(1).value.item(i) - next - Set mLast= objRes -End Function - -Function mFirst(objArgs) - 'Set objRes = New MalType - Set objRes = objArgs.value.item(1).value.item(0) - Set mFirst= objRes - 'msgbox 1 -End Function - -Function mGet(objArgs) - Set objRes = New MalType - 'objRes.Type = - Set objList = objArgs.value.item(1) - numIndex = objArgs.value.item(2).value - Set objRes = objList.value.Item(numIndex) - 'MsgBox objRes.type - Set mGet = objRes -End Function - -Function mSet(objArgs) - Set objRes = New MalType - 'objRes.Type = - 'MsgBox 1 - Set objList = objArgs.value.item(1) - numIndex = objArgs.value.item(2).value - 'MsgBox numIndex - Set objReplace = objArgs.value.item(3) - Set objList.value.Item(numIndex) = objReplace - 'MsgBox objRes.type - Set mSet = New MalType - mSet.Type = TYPE_NIL -End Function - -Function mprintln(objArgs) - Dim objRes,i - Set objRes = New MalType - objRes.Type = TYPE_NIL - For i = 1 To objArgs.Value.Count - 2 - wsh.stdout.write PrintMalType(objArgs.Value.Item(i), False) & " " - Next - If objArgs.Value.Count - 1 > 0 Then - wsh.stdout.write PrintMalType(objArgs.Value.Item(objArgs.Value.Count - 1), False) - End If - Set mprintln=objRes -End Function - -Function mprn(objArgs) - Dim objRes,i - Set objRes = New MalType - objRes.Type = TYPE_NIL - For i = 1 To objArgs.Value.Count - 2 - wsh.stdout.write PrintMalType(objArgs.Value.Item(i), True) & " " - Next - If objArgs.Value.Count - 1 > 0 Then - wsh.stdout.write PrintMalType(objArgs.Value.Item(objArgs.Value.Count - 1), True) - End If - Set mprn=objRes -End Function - -Function mstr(objArgs) - Dim objRes,i - Set objRes = New MalType - objRes.Type = TYPE_STRING - objRes.Value = "" - For i = 1 To objArgs.Value.Count - 1 - objRes.Value = objRes.Value & PrintMalType(objArgs.Value.Item(i), False) - Next - Set mstr=objRes -End Function - -Function mprstr(objArgs) - Dim objRes,i - Set objRes = New MalType - objRes.Type = TYPE_STRING - objRes.Value = "" - For i = 1 To objArgs.Value.Count - 2 - objRes.Value = objRes.Value & PrintMalType(objArgs.Value.Item(i), True) & " " - Next - If objArgs.Value.Count - 1 > 0 Then - objRes.Value = objRes.Value & PrintMalType(objArgs.Value.Item(objArgs.Value.Count - 1), True) - End If - Set mprstr=objRes -End Function - -Function mEqualGreater(objArgs) - CheckArgNum objArgs, 2 - Dim objRes,i - Set objRes = New MalType - objRes.Type = TYPE_BOOLEAN - objRes.Value = (objArgs.Value.Item(1).Value >= objArgs.Value.Item(2).Value) - Set mEqualGreater = objRes -End Function - -Function mEqualLess(objArgs) - CheckArgNum objArgs, 2 - Dim objRes,i - Set objRes = New MalType - objRes.Type = TYPE_BOOLEAN - objRes.Value = (objArgs.Value.Item(1).Value <= objArgs.Value.Item(2).Value) - Set mEqualLess = objRes -End Function - -Function mGreater(objArgs) - CheckArgNum objArgs, 2 - Dim objRes,i - Set objRes = New MalType - objRes.Type = TYPE_BOOLEAN - objRes.Value = (objArgs.Value.Item(1).Value > objArgs.Value.Item(2).Value) - Set mGreater = objRes -End Function - - -Function mLess(objArgs) - CheckArgNum objArgs, 2 - Dim objRes,i - Set objRes = New MalType - objRes.Type = TYPE_BOOLEAN - objRes.Value = (objArgs.Value.Item(1).Value < objArgs.Value.Item(2).Value) - Set mLess = objRes -End Function - - -Function mEqual(objArgs) - CheckArgNum objArgs, 2 - Dim objRes,i - Set objRes = New MalType - objRes.Type = TYPE_BOOLEAN - objRes.Value = (objArgs.Value.Item(1).Type = objArgs.Value.Item(2).Type) Or _ - ((objArgs.Value.Item(1).Type = TYPE_LIST Or objArgs.Value.Item(1).Type = TYPE_VECTOR) And _ - (objArgs.Value.Item(2).Type = TYPE_LIST Or objArgs.Value.Item(2).Type = TYPE_VECTOR)) - If objRes.Value Then - 'MsgBox objArgs.Value.Item(1).Type - If objArgs.Value.Item(1).Type = TYPE_LIST Or objArgs.Value.Item(1).Type = TYPE_VECTOR Then - objRes.Value = _ - (objArgs.Value.Item(1).Value.Count = objArgs.Value.Item(2).Value.Count) - If objRes.Value Then - Dim objTemp - For i = 0 To objArgs.Value.Item(1).Value.Count - 1 - 'an ugly recursion - - 'MsgBox objArgs.Value.Item(1).Value.Item(i).type - Set objTemp = New MalType - objTemp.Type = TYPE_LIST - Set objTemp.Value = CreateObject("System.Collections.Arraylist") - objTemp.Value.Add Null - objTemp.Value.Add objArgs.Value.Item(1).Value.Item(i) - objTemp.Value.Add objArgs.Value.Item(2).Value.Item(i) - - objRes.Value = objRes.Value And mEqual(objTemp).Value - Next - End If - Else - 'MsgBox objArgs.Value.Item(1).Value - 'MsgBox objArgs.Value.Item(2).Value - objRes.Value = _ - (objArgs.Value.Item(1).Value = objArgs.Value.Item(2).Value) - End If - End If - Set mEqual = objRes -End Function - -Sub Er(sInfo) - boolError = True - strError = sInfo End Sub -Function mListCount(objArgs) - CheckArgNum objArgs, 1 - Dim objRes,i - Set objRes = New MalType - objRes.Type = TYPE_NUMBER - If objArgs.Value.Item(1).Type = TYPE_LIST Then - objRes.Value = objArgs.Value.Item(1).Value.Count - ElseIf objArgs.Value.Item(1).Type = TYPE_NIL Then - objRes.Value = 0 - Else - Er "can't count" - End If - Set mListCount = objRes -End Function -Function mIsListEmpty(objArgs) - CheckArgNum objArgs, 1 - Dim objRes,i - Set objRes = New MalType - objRes.Type = TYPE_BOOLEAN - objRes.Value = (objArgs.Value.Item(1).Value.Count = 0) - Set mIsListEmpty = objRes -End Function +' Public objCoreNS +' Set objCoreNS = CreateObject("Scripting.Dictionary") +' objCoreNS.Add "+", GetRef("Add") +' objCoreNS.Add "-", GetRef("Subtract") +' objCoreNS.Add "*", GetRef("Multiply") +' objCoreNS.Add "/", GetRef("Divide") +' objCoreNS.Add "list", GetRef("mMakeList") +' objCoreNS.Add "list?", GetRef("mIsList") '1 +' objCoreNS.Add "empty?", GetRef("mIsListEmpty") '1 +' objCoreNS.Add "count", GetRef("mListCount") '1 +' objCoreNS.Add "=", GetRef("mEqual") '2 'both type & value +' objCoreNS.Add "<", GetRef("mLess") '2 'number only +' objCoreNS.Add ">", GetRef("mGreater") '2 'number only +' objCoreNS.Add "<=", GetRef("mEqualLess") '2 'number only +' objCoreNS.Add ">=", GetRef("mEqualGreater") '2 'number only +' objCoreNS.Add "pr-str", GetRef("mprstr") 'all 'ret str 'readable 'concat by space +' objCoreNS.Add "str", GetRef("mstr") 'all 'ret str '!readable 'concat by "" +' objCoreNS.Add "prn", GetRef("mprn") 'all 'to screen ret nil 'concat by space 'readable +' objCoreNS.Add "println", GetRef("mprintln") 'all 'to screen ret nil 'concat by space '!readable +' objCoreNS.Add "get", GetRef("mGet") +' objCoreNS.Add "set", GetRef("mSet") +' objCoreNS.Add "first", GetRef("mFirst") +' objCoreNS.Add "last", GetRef("mLast") -Function mIsList(objArgs) - CheckArgNum objArgs, 1 - Dim objRes,i - Set objRes = New MalType - objRes.Type = TYPE_BOOLEAN - objRes.Value = (objArgs.Value.Item(1).Type = TYPE_LIST) - Set mIsList = objRes -End Function +' Function mLast(objArgs) +' Set objRes = New MalType +' objRes.Type = TYPE_LIST +' set objRes.value = createobject("system.collections.arraylist") +' for i = 1 to objArgs.value.item(1).value.count - 1 +' objRes.value.add objArgs.value.item(1).value.item(i) +' next +' Set mLast= objRes +' End Function -Function mMakeList(objArgs) - Dim objRes,i - Set objRes = New MalType - objRes.Type = TYPE_LIST - Set objRes.Value = CreateObject("System.Collections.ArrayList") - For i = 1 To objArgs.Value.Count - 1 - objRes.Value.Add objArgs.Value.Item(i) - Next - Set mMakeList = objRes -End Function +' Function mFirst(objArgs) +' 'Set objRes = New MalType +' Set objRes = objArgs.value.item(1).value.item(0) +' Set mFirst= objRes +' 'msgbox 1 +' End Function -Function Add(objArgs) - CheckArgNum objArgs, 2 - Set Add = New MalType - Add.Type = TYPE_NUMBER - Add.Value = objArgs.Value.Item(1).Value + objArgs.Value.Item(2).Value -End Function +' Function mGet(objArgs) +' Set objRes = New MalType +' 'objRes.Type = +' Set objList = objArgs.value.item(1) +' numIndex = objArgs.value.item(2).value +' Set objRes = objList.value.Item(numIndex) +' 'MsgBox objRes.type +' Set mGet = objRes +' End Function -Function Subtract(objArgs) - CheckArgNum objArgs, 2 - Set Subtract = New MalType - Subtract.Type = TYPE_NUMBER - Subtract.Value = objArgs.Value.Item(1).Value - objArgs.Value.Item(2).Value -End Function +' Function mSet(objArgs) +' Set objRes = New MalType +' 'objRes.Type = +' 'MsgBox 1 +' Set objList = objArgs.value.item(1) +' numIndex = objArgs.value.item(2).value +' 'MsgBox numIndex +' Set objReplace = objArgs.value.item(3) +' Set objList.value.Item(numIndex) = objReplace +' 'MsgBox objRes.type +' Set mSet = New MalType +' mSet.Type = TYPE_NIL +' End Function -Function Multiply(objArgs) - CheckArgNum objArgs, 2 - Set Multiply = New MalType - Multiply.Type = TYPE_NUMBER - Multiply.Value = objArgs.Value.Item(1).Value * objArgs.Value.Item(2).Value -End Function +' Function mprintln(objArgs) +' Dim objRes,i +' Set objRes = New MalType +' objRes.Type = TYPE_NIL +' For i = 1 To objArgs.Value.Count - 2 +' wsh.stdout.write PrintMalType(objArgs.Value.Item(i), False) & " " +' Next +' If objArgs.Value.Count - 1 > 0 Then +' wsh.stdout.write PrintMalType(objArgs.Value.Item(objArgs.Value.Count - 1), False) +' End If +' Set mprintln=objRes +' End Function -Function Divide(objArgs) - CheckArgNum objArgs, 2 - Set Divide = New MalType - Divide.Type = TYPE_NUMBER - Divide.Value = objArgs.Value.Item(1).Value \ objArgs.Value.Item(2).Value -End Function +' Function mprn(objArgs) +' Dim objRes,i +' Set objRes = New MalType +' objRes.Type = TYPE_NIL +' For i = 1 To objArgs.Value.Count - 2 +' wsh.stdout.write PrintMalType(objArgs.Value.Item(i), True) & " " +' Next +' If objArgs.Value.Count - 1 > 0 Then +' wsh.stdout.write PrintMalType(objArgs.Value.Item(objArgs.Value.Count - 1), True) +' End If +' Set mprn=objRes +' End Function + +' Function mstr(objArgs) +' Dim objRes,i +' Set objRes = New MalType +' objRes.Type = TYPE_STRING +' objRes.Value = "" +' For i = 1 To objArgs.Value.Count - 1 +' objRes.Value = objRes.Value & PrintMalType(objArgs.Value.Item(i), False) +' Next +' Set mstr=objRes +' End Function + +' Function mprstr(objArgs) +' Dim objRes,i +' Set objRes = New MalType +' objRes.Type = TYPE_STRING +' objRes.Value = "" +' For i = 1 To objArgs.Value.Count - 2 +' objRes.Value = objRes.Value & PrintMalType(objArgs.Value.Item(i), True) & " " +' Next +' If objArgs.Value.Count - 1 > 0 Then +' objRes.Value = objRes.Value & PrintMalType(objArgs.Value.Item(objArgs.Value.Count - 1), True) +' End If +' Set mprstr=objRes +' End Function + +' Function mEqualGreater(objArgs) +' CheckArgNum objArgs, 2 +' Dim objRes,i +' Set objRes = New MalType +' objRes.Type = TYPE_BOOLEAN +' objRes.Value = (objArgs.Value.Item(1).Value >= objArgs.Value.Item(2).Value) +' Set mEqualGreater = objRes +' End Function + +' Function mEqualLess(objArgs) +' CheckArgNum objArgs, 2 +' Dim objRes,i +' Set objRes = New MalType +' objRes.Type = TYPE_BOOLEAN +' objRes.Value = (objArgs.Value.Item(1).Value <= objArgs.Value.Item(2).Value) +' Set mEqualLess = objRes +' End Function + +' Function mGreater(objArgs) +' CheckArgNum objArgs, 2 +' Dim objRes,i +' Set objRes = New MalType +' objRes.Type = TYPE_BOOLEAN +' objRes.Value = (objArgs.Value.Item(1).Value > objArgs.Value.Item(2).Value) +' Set mGreater = objRes +' End Function + + +' Function mLess(objArgs) +' CheckArgNum objArgs, 2 +' Dim objRes,i +' Set objRes = New MalType +' objRes.Type = TYPE_BOOLEAN +' objRes.Value = (objArgs.Value.Item(1).Value < objArgs.Value.Item(2).Value) +' Set mLess = objRes +' End Function + + +' Function mEqual(objArgs) +' CheckArgNum objArgs, 2 +' Dim objRes,i +' Set objRes = New MalType +' objRes.Type = TYPE_BOOLEAN +' objRes.Value = (objArgs.Value.Item(1).Type = objArgs.Value.Item(2).Type) Or _ +' ((objArgs.Value.Item(1).Type = TYPE_LIST Or objArgs.Value.Item(1).Type = TYPE_VECTOR) And _ +' (objArgs.Value.Item(2).Type = TYPE_LIST Or objArgs.Value.Item(2).Type = TYPE_VECTOR)) +' If objRes.Value Then +' 'MsgBox objArgs.Value.Item(1).Type +' If objArgs.Value.Item(1).Type = TYPE_LIST Or objArgs.Value.Item(1).Type = TYPE_VECTOR Then +' objRes.Value = _ +' (objArgs.Value.Item(1).Value.Count = objArgs.Value.Item(2).Value.Count) +' If objRes.Value Then +' Dim objTemp +' For i = 0 To objArgs.Value.Item(1).Value.Count - 1 +' 'an ugly recursion + +' 'MsgBox objArgs.Value.Item(1).Value.Item(i).type +' Set objTemp = New MalType +' objTemp.Type = TYPE_LIST +' Set objTemp.Value = CreateObject("System.Collections.Arraylist") +' objTemp.Value.Add Null +' objTemp.Value.Add objArgs.Value.Item(1).Value.Item(i) +' objTemp.Value.Add objArgs.Value.Item(2).Value.Item(i) + +' objRes.Value = objRes.Value And mEqual(objTemp).Value +' Next +' End If +' Else +' 'MsgBox objArgs.Value.Item(1).Value +' 'MsgBox objArgs.Value.Item(2).Value +' objRes.Value = _ +' (objArgs.Value.Item(1).Value = objArgs.Value.Item(2).Value) +' End If +' End If +' Set mEqual = objRes +' End Function + +' Sub Er(sInfo) +' boolError = True +' strError = sInfo +' End Sub + +' Function mListCount(objArgs) +' CheckArgNum objArgs, 1 +' Dim objRes,i +' Set objRes = New MalType +' objRes.Type = TYPE_NUMBER +' If objArgs.Value.Item(1).Type = TYPE_LIST Then +' objRes.Value = objArgs.Value.Item(1).Value.Count +' ElseIf objArgs.Value.Item(1).Type = TYPE_NIL Then +' objRes.Value = 0 +' Else +' Er "can't count" +' End If +' Set mListCount = objRes +' End Function + +' Function mIsListEmpty(objArgs) +' CheckArgNum objArgs, 1 +' Dim objRes,i +' Set objRes = New MalType +' objRes.Type = TYPE_BOOLEAN +' objRes.Value = (objArgs.Value.Item(1).Value.Count = 0) +' Set mIsListEmpty = objRes +' End Function + +' Function mIsList(objArgs) +' CheckArgNum objArgs, 1 +' Dim objRes,i +' Set objRes = New MalType +' objRes.Type = TYPE_BOOLEAN +' objRes.Value = (objArgs.Value.Item(1).Type = TYPE_LIST) +' Set mIsList = objRes +' End Function + +' Function mMakeList(objArgs) +' Dim objRes,i +' Set objRes = New MalType +' objRes.Type = TYPE_LIST +' Set objRes.Value = CreateObject("System.Collections.ArrayList") +' For i = 1 To objArgs.Value.Count - 1 +' objRes.Value.Add objArgs.Value.Item(i) +' Next +' Set mMakeList = objRes +' End Function + +' Function Add(objArgs) +' CheckArgNum objArgs, 2 +' Set Add = New MalType +' Add.Type = TYPE_NUMBER +' Add.Value = objArgs.Value.Item(1).Value + objArgs.Value.Item(2).Value +' End Function + +' Function Subtract(objArgs) +' CheckArgNum objArgs, 2 +' Set Subtract = New MalType +' Subtract.Type = TYPE_NUMBER +' Subtract.Value = objArgs.Value.Item(1).Value - objArgs.Value.Item(2).Value +' End Function + +' Function Multiply(objArgs) +' CheckArgNum objArgs, 2 +' Set Multiply = New MalType +' Multiply.Type = TYPE_NUMBER +' Multiply.Value = objArgs.Value.Item(1).Value * objArgs.Value.Item(2).Value +' End Function + +' Function Divide(objArgs) +' CheckArgNum objArgs, 2 +' Set Divide = New MalType +' Divide.Type = TYPE_NUMBER +' Divide.Value = objArgs.Value.Item(1).Value \ objArgs.Value.Item(2).Value +' End Function diff --git a/impls/vbs/install.vbs b/impls/vbs/install.vbs new file mode 100644 index 00000000..a66409b0 --- /dev/null +++ b/impls/vbs/install.vbs @@ -0,0 +1,3 @@ +On Error Resume Next +With CreateObject("System.Collections.ArrayList") +End With \ No newline at end of file diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs index 27e9268a..84b13c7f 100644 --- a/impls/vbs/printer.vbs +++ b/impls/vbs/printer.vbs @@ -13,7 +13,7 @@ Function PrintMalType(objMal, boolReadable) Dim i Select Case objMal.Type Case TYPES.LIST - With ValueOf(objMal) + With objMal For i = 0 To .Count - 2 varResult = varResult & _ PrintMalType(.Item(i), boolReadable) & " " @@ -25,7 +25,7 @@ Function PrintMalType(objMal, boolReadable) End With varResult = "(" & varResult & ")" Case TYPES.VECTOR - With ValueOf(objMal) + With objMal For i = 0 To .Count - 2 varResult = varResult & _ PrintMalType(.Item(i), boolReadable) & " " @@ -37,7 +37,7 @@ Function PrintMalType(objMal, boolReadable) End With varResult = "[" & varResult & "]" Case TYPES.HASHMAP - With ValueOf(objMal) + With objMal Dim arrKeys arrKeys = .Keys For i = 0 To .Count - 2 @@ -54,12 +54,12 @@ Function PrintMalType(objMal, boolReadable) varResult = "{" & varResult & "}" Case TYPES.STRING If boolReadable Then - varResult = EscapeString(ValueOf(objMal)) + varResult = EscapeString(objMal.Value) Else - varResult = ValueOf(objMal) + varResult = objMal.Value End If Case TYPES.BOOLEAN - If ValueOf(objMal) Then + If objMal.Value Then varResult = "true" Else varResult = "false" @@ -67,15 +67,15 @@ Function PrintMalType(objMal, boolReadable) Case TYPES.NIL varResult = "nil" Case TYPES.NUMBER - varResult = CStr(ValueOf(objMal)) + varResult = CStr(objMal.Value) Case TYPES.LAMBDA varResult = "#" Case TYPES.PROCEDURE varResult = "#" Case TYPES.KEYWORD - varResult = ValueOf(objMal) + varResult = objMal.Value Case TYPES.SYMBOL - varResult = ValueOf(objMal) + varResult = objMal.Value Case Else Err.Raise vbObjectError, _ "PrintMalType", "unknown type" diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index e9f69348..f258ca0a 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -1,53 +1,63 @@ Option Explicit Function ReadString(strCode) - Set ReadString = ReadForm(Tokenize(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 strRaw, objTokens + Private objQueue Private objRE Private Sub Class_Initialize Set objRE = New RegExp With objRE - .Pattern = "[\s,]*(~@|[\[\]{}()'`~^@]|""(?:\\.|[^\\""])*""?|;.*|[^\s\[\]{}('""`,;)]*)" + .Pattern = "[\s,]*" + _ + "(" + _ + "~@" + "|" + _ + "[\[\]{}()'`~^@]" + "|" + _ + """(?:\\.|[^\\""])*""?" + "|" + _ + ";.*" + "|" + _ + "[^\s\[\]{}('""`,;)]*" + _ + ")" .IgnoreCase = True .Global = True End With - Set objTokens = CreateObject("System.Collections.Queue") + Set objQueue = CreateObject("System.Collections.Queue") End Sub Public Function Init(strCode) - strRaw = 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 - ' Drop comments - objTokens.Enqueue Trim(strToken) + objQueue.Enqueue strToken End If Next End Function Public Function Current() - Current = objTokens.Peek() + Current = objQueue.Peek() End Function Public Function MoveToNext() - MoveToNext = objTokens.Dequeue() + MoveToNext = objQueue.Dequeue() End Function Public Function AtEnd() - AtEnd = (objTokens.Count = 0) + AtEnd = (objQueue.Count = 0) End Function Public Function Count() - Count = objTokens.Count + Count = objQueue.Count End Function End Class @@ -81,18 +91,13 @@ Function ReadForm(objTokens) ' Return Nothing / MalType Set varResult = ReadSpecial(objTokens) ElseIf InStr(")]}", strToken) Then Err.Raise vbObjectError, _ - "ReadForm", "unbalanced parentheses" + "ReadForm", "Unbalanced parentheses." ElseIf strToken = "^" Then Set varResult = ReadMetadata(objTokens) Else Set varResult = ReadAtom(objTokens) End If - If Not objTokens.AtEnd() Then - 'Err.Raise vbObjectError, _ - ' "ReadForm", "extra token(s): " + objTokens.Current() - End If - Set ReadForm = varResult End Function @@ -100,11 +105,11 @@ Function ReadMetadata(objTokens) Dim varResult Call objTokens.MoveToNext() - Dim objTmp - Set objTmp = ReadForm(objTokens) + Dim objTemp + Set objTemp = ReadForm(objTokens) Set varResult = NewMalList(Array( _ - NewMalType(TYPES.SYMBOL, "with-meta"), _ - ReadForm(objTokens), objTmp)) + NewMalSym("with-meta"), _ + ReadForm(objTokens), objTemp)) Set ReadMetadata = varResult End Function @@ -127,13 +132,14 @@ Function ReadSpecial(objTokens) strAlias = "deref" Case Else Err.Raise vbObjectError, _ - "ReadSpecial", "unknown token " & strAlias + "ReadSpecial", "Unknown token '" & strAlias & "'." End Select Call objTokens.MoveToNext() Set varResult = NewMalList(Array( _ - NewMalType(TYPES.SYMBOL, strAlias), _ + NewMalSym(strAlias), _ ReadForm(objTokens))) + Set ReadSpecial = varResult End Function @@ -143,7 +149,7 @@ Function ReadList(objTokens) If objTokens.AtEnd() Then Err.Raise vbObjectError, _ - "ReadList", "unbalanced parentheses" + "ReadList", "Unbalanced parentheses." End If Set varResult = NewMalList(Array()) @@ -155,7 +161,7 @@ Function ReadList(objTokens) If objTokens.MoveToNext() <> ")" Then Err.Raise vbObjectError, _ - "ReadList", "unbalanced parentheses" + "ReadList", "Unbalanced parentheses." End If Set ReadList = varResult @@ -167,10 +173,10 @@ Function ReadVector(objTokens) If objTokens.AtEnd() Then Err.Raise vbObjectError, _ - "ReadVector", "unbalanced parentheses" + "ReadVector", "Unbalanced parentheses." End If - Set varResult = NewMalVector(Array()) + Set varResult = NewMalVec(Array()) With varResult While objTokens.Count() > 1 And objTokens.Current() <> "]" .Add ReadForm(objTokens) @@ -179,7 +185,7 @@ Function ReadVector(objTokens) If objTokens.MoveToNext() <> "]" Then Err.Raise vbObjectError, _ - "ReadVector", "unbalanced parentheses" + "ReadVector", "Unbalanced parentheses." End If Set ReadVector = varResult @@ -191,10 +197,10 @@ Function ReadHashmap(objTokens) If objTokens.Count = 0 Then Err.Raise vbObjectError, _ - "ReadHashmap", "unbalanced parentheses" + "ReadHashmap", "Unbalanced parentheses." End If - Set varResult = NewMalHashmap(Array(), Array()) - + + Set varResult = NewMalMap(Array(), Array()) Dim objKey, objValue With varResult While objTokens.Count > 2 And objTokens.Current() <> "}" @@ -203,12 +209,12 @@ Function ReadHashmap(objTokens) .Add objKey, objValue Wend End With - + If objTokens.MoveToNext() <> "}" Then Err.Raise vbObjectError, _ - "ReadHashmap", "unbalanced parentheses" + "ReadHashmap", "Unbalanced parentheses." End If - + Set ReadHashmap = varResult End Function @@ -220,22 +226,22 @@ Function ReadAtom(objTokens) Select Case strAtom Case "true" - Set varResult = NewMalType(TYPES.BOOLEAN, True) + Set varResult = NewMalBool(True) Case "false" - Set varResult = NewMalType(TYPES.BOOLEAN, False) + Set varResult = NewMalBool(False) Case "nil" - Set varResult = NewMalType(TYPES.NIL, Empty) + Set varResult = NewMalNil() Case Else Select Case Left(strAtom, 1) Case ":" - Set varResult = NewMalType(TYPES.KEYWORD, strAtom) + Set varResult = NewMalKwd(strAtom) Case """" - Set varResult = NewMalType(TYPES.STRING, ParseString(strAtom)) + Set varResult = NewMalStr(ParseString(strAtom)) Case Else If IsNumeric(strAtom) Then - Set varResult = NewMalType(TYPES.NUMBER, Eval(strAtom)) + Set varResult = NewMalNum(Eval(strAtom)) Else - Set varResult = NewMalType(TYPES.SYMBOL, strAtom) + Set varResult = NewMalSym(strAtom) End If End Select End Select @@ -246,7 +252,7 @@ End Function Function ParseString(strRaw) If Right(strRaw, 1) <> """" Or Len(strRaw) < 2 Then Err.Raise vbObjectError, _ - "ParseString", "unterminated string, got EOF" + "ParseString", "Unterminated string, got EOF." End If Dim strTemp @@ -275,7 +281,7 @@ Function ParseString(strRaw) ParseString = ParseString & Right(strTemp, 1) Else Err.Raise vbObjectError, _ - "ParseString", "unterminated string, got EOF" + "ParseString", "Unterminated string, got EOF." End If End If End Function diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs index 454042bb..31475478 100644 --- a/impls/vbs/step1_read_print.vbs +++ b/impls/vbs/step1_read_print.vbs @@ -1,6 +1,6 @@ Option Explicit -Include "Core.vbs" +Include "Types.vbs" Include "Reader.vbs" Include "Printer.vbs" diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs new file mode 100644 index 00000000..929db9f7 --- /dev/null +++ b/impls/vbs/types.vbs @@ -0,0 +1,249 @@ +Option Explicit + +Dim TYPES +Set TYPES = New MalTypes + +Class MalTypes + Public LIST, VECTOR, HASHMAP, [BOOLEAN], NIL + Public KEYWORD, [STRING], NUMBER, SYMBOL + Public LAMBDA, PROCEDURE + + Public [TypeName] + Private Sub Class_Initialize + [TypeName] = Array( _ + "LIST", "VECTOR", "HASHMAP", "BOOLEAN", _ + "NIL", "KEYWORD", "STRING", "NUMBER", _ + "SYMBOL", "LAMBDA", "PROCEDURE") + + Dim i + For i = 0 To UBound([TypeName]) + Execute "[" + [TypeName](i) + "] = " + CStr(i) + Next + End Sub +End Class + +Class MalType + Public [Type] + Public Value + + Public Function Init(lngType, varValue) + [Type] = lngType + Value = varValue + End Function + + Public Function Copy() + 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, Null) +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 MalList ' Extends MalType + Public [Type] + Public Value + + 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 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 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 + + Public Function Add(varKey, varValue) + Value.Add varKey, varValue + End Function + + Public Property Get Keys() + Keys = Value.Keys + End Property + + Public Function Count() + Count = Value.Count + 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 +End Class + +Function NewMalMap(arrKeys, arrValues) + Dim varResult + Set varResult = New MalHashmap + varResult.Init arrKeys, arrValues + Set NewMalMap = varResult +End Function + +Class MalProcedure 'Extends MalType + Public [Type] + Public Value + + Public boolBuiltin + Public boolSpec + Private Sub Class_Initialize + [Type] = TYPES.PROCEDURE + End Sub + + Public Function Init(objFunction, boolIsBuiltin, boolIsSpec) + Set Value = objFunction + boolBuiltin = boolIsBuiltin + boolSpec = boolIsSpec + End Function + + Public Function Apply(objArgs, objEnv) + Dim varResult + If boolBuiltin Then + If boolSpec Then + Set varResult = Value(objArgs, objEnv) + Else + Set varResult = Value(EvaluateRest(objArgs, objEnv)) + End If + Else + wsh.echo "impl later" + End If + Set Apply = varResult + End Function +End Class + +Function NewVbsProc(strFnName, boolSpec) + Dim varResult + Set varResult = New MalProcedure + varResult.Init GetRef(strFnName), True, boolSpec + Set NewVbsProc = varResult +End Function + +Sub CheckArgNum(objArgs, lngExpect) + If objArgs.Value.Count - 1 <> lngExpect Then + boolError = True + strError = "wrong number of arguments" + Call REPL() + End If +End Sub \ No newline at end of file From 5e162c158144e32083dda41d3520af8a61433dcf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E8=80=81=E5=88=98?= <632171029@qq.com> Date: Thu, 19 Jan 2023 19:36:39 +0800 Subject: [PATCH 22/44] Rewrite step2 --- impls/vbs/step2_eval.vbs | 179 +++++++++++++++++++++++---------------- impls/vbs/types.vbs | 10 +-- 2 files changed, 108 insertions(+), 81 deletions(-) diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs index bc5123ad..b7ed5f45 100644 --- a/impls/vbs/step2_eval.vbs +++ b/impls/vbs/step2_eval.vbs @@ -1,67 +1,95 @@ Option Explicit -Include "Core.vbs" +Include "Types.vbs" Include "Reader.vbs" Include "Printer.vbs" -Dim objEnv -Set objEnv = CreateObject("Scripting.Dictionary") -objEnv.Add "+", GetRef("Add") -objEnv.Add "-", GetRef("Subtract") -objEnv.Add "*", GetRef("Multiply") -objEnv.Add "/", GetRef("Divide") +Class Enviroment + Private objDict + Private objSelf -Sub CheckArgNum(objArgs, lngExpect) - If objArgs.Value.Count - 1 <> lngExpect Then - boolError = True - strError = "wrong number of arguments" - Call REPL() - End If -End Sub + 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 Add(objArgs) CheckArgNum objArgs, 2 - Set Add = New MalType - Add.Type = TYPE_NUMBER - Add.Value = objArgs.Value.Item(1).Value + objArgs.Value.Item(2).Value + Set Add = NewMalNum( _ + objArgs.Item(1).Value + objArgs.Item(2).Value) End Function +objEnv.Add NewMalSym("+"), NewVbsProc("Add", False) -Function Subtract(objArgs) +Function [Sub](objArgs) CheckArgNum objArgs, 2 - Set Subtract = New MalType - Subtract.Type = TYPE_NUMBER - Subtract.Value = objArgs.Value.Item(1).Value - objArgs.Value.Item(2).Value + Set [Sub] = NewMalNum( _ + objArgs.Item(1).Value - objArgs.Item(2).Value) End Function +objEnv.Add NewMalSym("-"), NewVbsProc("Sub", False) -Function Multiply(objArgs) +Function Mul(objArgs) CheckArgNum objArgs, 2 - Set Multiply = New MalType - Multiply.Type = TYPE_NUMBER - Multiply.Value = objArgs.Value.Item(1).Value * objArgs.Value.Item(2).Value + Set Mul = NewMalNum( _ + objArgs.Item(1).Value * objArgs.Item(2).Value) End Function +objEnv.Add NewMalSym("*"), NewVbsProc("Mul", False) -Function Divide(objArgs) +Function Div(objArgs) CheckArgNum objArgs, 2 - Set Divide = New MalType - Divide.Type = TYPE_NUMBER - Divide.Value = objArgs.Value.Item(1).Value \ objArgs.Value.Item(2).Value + Set Div = NewMalNum( _ + objArgs.Item(1).Value \ objArgs.Item(2).Value) End Function +objEnv.Add NewMalSym("/"), NewVbsProc("Div", False) +Sub CheckArgNum(objArgs, lngArgNum) + If objArgs.Count - 1 <> lngArgNum Then + Err.Raise vbObjectError, _ + "CheckArgNum", "Wrong number of arguments." + End IF +End Sub Call REPL() Sub REPL() Dim strCode, strResult While True - If boolError Then - WScript.StdErr.WriteLine "ERROR: " & strError - boolError = False - End If WScript.StdOut.Write("user> ") + On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + On Error Resume Next + WScript.Echo REP(strCode) + If Err.Number <> 0 Then + WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + End If On Error Goto 0 - WScript.Echo REP(strCode) Wend End Sub @@ -69,57 +97,64 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function -Function Evaluate(objCode, objEnv) +Function Evaluate(objCode, objEnv) ' Return Nothing / objCode If TypeName(objCode) = "Nothing" Then - Call REPL() + Set Evaluate = Nothing + Exit Function End If - - If objCode.Type = TYPE_LIST Then - If objCode.Value.Count = 0 Then + Dim varRet + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () Set Evaluate = objCode Exit Function End If - - Set Evaluate = EvaluateAST(objCode, objEnv) - Set Evaluate = Evaluate.Value.Item(0)(Evaluate) + Set objCode.Item(0) = Evaluate(objCode.Item(0), objEnv) + Set varRet = objCode.Item(0).Apply(objCode, objEnv) Else - Set Evaluate = EvaluateAST(objCode, objEnv) + Set varRet = EvaluateAST(objCode, objEnv) End If + + Set Evaluate = varRet End Function + Function EvaluateAST(objCode, objEnv) - Dim objResult, i + Dim varRet, i Select Case objCode.Type - Case TYPE_SYMBOL - If objEnv.Exists(objCode.Value) Then - Set objResult = objEnv(objCode.Value) - Else - boolError = True - strError = "symbol not found" - Call REPL() - End If - Case TYPE_LIST - For i = 0 To objCode.Value.Count - 1 - Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + For i = 0 To objCode.Count() - 1 + Set objCode.Item(i) = Evaluate(objCode.Item(i)) Next - Set objResult = objCode - Case TYPE_VECTOR - For i = 0 To objCode.Value.Count - 1 - Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) + Set varRet = objCode + Case TYPES.HASHMAP + For Each i In objCode.Keys() + Set objCode.Item(i) = Evaluate(objCode.Item(i)) Next - Set objResult = objCode - Case TYPE_HASHMAP - Dim arrKeys - arrKeys = objCode.Value.Keys - For i = 0 To objCode.Value.Count - 1 - Set objCode.Value.Item(arrKeys(i)) = _ - Evaluate(objCode.Value.Item(arrKeys(i)), objEnv) - Next - Set objResult = objCode + Set varRet = objCode Case Else - Set objResult = objCode + Set varRet = objCode End Select - Set EvaluateAST = objResult + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + For i = 1 To objCode.Count() - 1 + Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) + Next + Set varRet = objCode + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet End Function Function Print(objCode) diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index 929db9f7..90c7d2f3 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -238,12 +238,4 @@ Function NewVbsProc(strFnName, boolSpec) Set varResult = New MalProcedure varResult.Init GetRef(strFnName), True, boolSpec Set NewVbsProc = varResult -End Function - -Sub CheckArgNum(objArgs, lngExpect) - If objArgs.Value.Count - 1 <> lngExpect Then - boolError = True - strError = "wrong number of arguments" - Call REPL() - End If -End Sub \ No newline at end of file +End Function \ No newline at end of file From 57a446ddd2def12d0e55eaa6d78dd4e6c1a0a578 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E8=80=81=E5=88=98?= <632171029@qq.com> Date: Thu, 19 Jan 2023 21:11:11 +0800 Subject: [PATCH 23/44] rewrite step3 & fix bugs --- impls/vbs/env.vbs | 128 +++++++----- impls/vbs/step2_eval.vbs | 4 +- impls/vbs/step3_env.vbs | 424 +++++++++++++++++++++++++-------------- 3 files changed, 353 insertions(+), 203 deletions(-) diff --git a/impls/vbs/env.vbs b/impls/vbs/env.vbs index a3f5099d..94e34857 100644 --- a/impls/vbs/env.vbs +++ b/impls/vbs/env.vbs @@ -1,73 +1,93 @@ +Option Explicit -class Environment - Private objOuterEnv - Public objBindings - Private objSelf +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 objBindings = CreateObject("Scripting.Dictionary") - Set objOuterEnv = Nothing + Set objBinds = CreateObject("Scripting.Dictionary") + Set objOuter = Nothing Set objSelf = Nothing End Sub - Public Sub Init(objBinds, objExpressions) - 'MsgBox objExpressions.type - Dim i,flag - flag = False - For i = 0 To objBinds.Value.Count - 1 - If objBinds.Value.Item(i).Value = "&" Then flag=True - If flag Then - 'assume i+1 = objBinds.Value.Count - 1 - Dim oTmp - Set oTmp = New MalType - oTmp.Type = TYPE_LIST - Set oTmp.Value = CreateObject("System.Collections.ArrayList") - Dim j - For j = i+1 To objExpressions.Value.Count - 1 - oTmp.Value.Add Evaluate(objExpressions.Value.Item(j), objSelf) - Next - 'MsgBox objBinds.Value.Item(i+1) - Add objBinds.Value.Item(i+1).Value, oTmp - Exit For - Else - Add objBinds.Value.Item(i).Value, _ - Evaluate(objExpressions.Value.Item(i+1), objSelf) - End If - 'wsh.echo objBinds.Value.Item(i).Value - 'wsh.echo objExpressions.Value.Item(i).type - 'wsh.echo TypeName(Evaluate(objExpressions.Value.Item(i), objSelf)) - 'wsh.echo Evaluate(objExpressions.Value.Item(i), objSelf).type - Next - 'MsgBox objBindings("a") - End Sub - - Public Function SetOuter(objEnv) - Set objOuterEnv = objEnv - End Function - - Public Function SetSelf(objEnv) + Public Property Set Outer(objEnv) + Set objOuter = objEnv + End Property + + Public Property Set Self(objEnv) Set objSelf = objEnv - End Function + End Property + + ' Public objBindings + ' Public Sub Init(objBinds, objExpressions) + ' Dim boolVarLen + ' boolVarLen = False + + ' Dim i + ' For i = 0 To objBinds.Value.Count - 1 + ' If objBinds.Value.Item(i).Value = "&" Then flag=True + ' If flag Then + ' 'assume i+1 = objBinds.Value.Count - 1 + ' Dim oTmp + ' Set oTmp = New MalType + ' oTmp.Type = TYPE_LIST + ' Set oTmp.Value = CreateObject("System.Collections.ArrayList") + ' Dim j + ' For j = i+1 To objExpressions.Value.Count - 1 + ' oTmp.Value.Add Evaluate(objExpressions.Value.Item(j), objSelf) + ' Next + ' 'MsgBox objBinds.Value.Item(i+1) + ' Add objBinds.Value.Item(i+1).Value, oTmp + ' Exit For + ' Else + ' Add objBinds.Value.Item(i).Value, _ + ' Evaluate(objExpressions.Value.Item(i+1), objSelf) + ' End If + ' 'wsh.echo objBinds.Value.Item(i).Value + ' 'wsh.echo objExpressions.Value.Item(i).type + ' 'wsh.echo TypeName(Evaluate(objExpressions.Value.Item(i), objSelf)) + ' 'wsh.echo Evaluate(objExpressions.Value.Item(i), objSelf).type + ' Next + ' 'MsgBox objBindings("a") + ' End Sub + Public Sub Add(varKey, varValue) - 'objBindings.Add varKey, varValue - Set objBindings(varKey) = varValue + Set objBinds.Item(varKey.Value) = varValue End Sub Public Function Find(varKey) - If objBindings.Exists(varKey) Then - Set Find = objSelf + Dim varRet + If objBinds.Exists(varKey.Value) Then + Set varRet = objSelf Else - If TypeName(objOuterEnv) <> "Nothing" Then - Set Find = objOuterEnv.Find(varKey) + If TypeName(objOuter) <> "Nothing" Then + Set varRet = objOuter.Find(varKey) Else - boolError = True - strError = "symbol " & varKey & " not found" - Call REPL() + Err.Raise vbObjectError, _ + "Environment", "Symbol '" + varKey.Value + "' not found." End If End If + + Set Find = varRet End Function Public Function [Get](varKey) - Set [Get] = Find(varKey).objBindings(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 +End Class \ No newline at end of file diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs index b7ed5f45..ad5c16bc 100644 --- a/impls/vbs/step2_eval.vbs +++ b/impls/vbs/step2_eval.vbs @@ -128,12 +128,12 @@ Function EvaluateAST(objCode, objEnv) "EvaluateAST", "Unexpect type." Case TYPES.VECTOR For i = 0 To objCode.Count() - 1 - Set objCode.Item(i) = Evaluate(objCode.Item(i)) + Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) Next Set varRet = objCode Case TYPES.HASHMAP For Each i In objCode.Keys() - Set objCode.Item(i) = Evaluate(objCode.Item(i)) + Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) Next Set varRet = objCode Case Else diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs index 2a5d0b23..1d876bfd 100644 --- a/impls/vbs/step3_env.vbs +++ b/impls/vbs/step3_env.vbs @@ -1,71 +1,113 @@ Option Explicit -Include "Core.vbs" +Include "Types.vbs" Include "Reader.vbs" Include "Printer.vbs" Include "Env.vbs" Dim objEnv -Set objEnv = New Environment -objEnv.SetSelf objEnv -objEnv.SetOuter Nothing -objEnv.Add "+", GetRef("Add") -objEnv.Add "-", GetRef("Subtract") -objEnv.Add "*", GetRef("Multiply") -objEnv.Add "/", GetRef("Divide") +Set objEnv = NewEnv(Nothing) +Function MAdd(objArgs) + CheckArgNum objArgs, 2 + Set MAdd = NewMalNum( _ + objArgs.Item(1).Value + objArgs.Item(2).Value) +End Function +objEnv.Add NewMalSym("+"), NewVbsProc("MAdd", False) -Sub CheckArgNum(objArgs, lngExpect) - If objArgs.Value.Count - 1 <> lngExpect Then - boolError = True - strError = "wrong number of arguments" - Call REPL() - End If +Function MSub(objArgs) + CheckArgNum objArgs, 2 + Set MSub = NewMalNum( _ + objArgs.Item(1).Value - objArgs.Item(2).Value) +End Function +objEnv.Add NewMalSym("-"), NewVbsProc("MSub", False) + +Function MMul(objArgs) + CheckArgNum objArgs, 2 + Set MMul = NewMalNum( _ + objArgs.Item(1).Value * objArgs.Item(2).Value) +End Function +objEnv.Add NewMalSym("*"), NewVbsProc("MMul", False) + +Function MDiv(objArgs) + CheckArgNum objArgs, 2 + 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 -Function Add(objArgs) - CheckArgNum objArgs, 2 - Set Add = New MalType - Add.Type = TYPE_NUMBER - Add.Value = objArgs.Value.Item(1).Value + objArgs.Value.Item(2).Value -End Function +Sub CheckType(objMal, varType) + If objMal.Type <> varType Then + Err.Raise vbObjectError, _ + "CheckType", "Wrong argument type." + End IF +End Sub -Function Subtract(objArgs) +Function MDef(objArgs, objEnv) + Dim varRet CheckArgNum objArgs, 2 - Set Subtract = New MalType - Subtract.Type = TYPE_NUMBER - Subtract.Value = objArgs.Value.Item(1).Value - objArgs.Value.Item(2).Value + 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 Multiply(objArgs) +Function MLet(objArgs, objEnv) + Dim varRet CheckArgNum objArgs, 2 - Set Multiply = New MalType - Multiply.Type = TYPE_NUMBER - Multiply.Value = objArgs.Value.Item(1).Value * objArgs.Value.Item(2).Value -End Function -Function Divide(objArgs) - CheckArgNum objArgs, 2 - Set Divide = New MalType - Divide.Type = TYPE_NUMBER - Divide.Value = objArgs.Value.Item(1).Value \ objArgs.Value.Item(2).Value -End Function + 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 - If boolError Then - WScript.StdErr.WriteLine "ERROR: " & strError - boolError = False - End If WScript.StdOut.Write("user> ") + On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + 'On Error Resume Next + WScript.Echo REP(strCode) + If Err.Number <> 0 Then + WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + End If On Error Goto 0 - WScript.Echo REP(strCode) Wend End Sub @@ -73,126 +115,64 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function -Function Evaluate(objCode, objEnv) - Dim i +Function Evaluate(objCode, objEnv) ' Return Nothing / objCode If TypeName(objCode) = "Nothing" Then - Call REPL() + Set Evaluate = Nothing + Exit Function End If - - If objCode.Type = TYPE_LIST Then - If objCode.Value.Count = 0 Then + Dim varRet + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () Set Evaluate = objCode Exit Function End If - - Dim objSymbol - Set objSymbol = Evaluate(objCode.Value.Item(0), objEnv) - If TypeName(objSymbol) = "MalType" Then - 'MsgBox TypeName(objCode.value) - Select Case objSymbol.Value - Case "def!" - CheckArgNum objCode, 2 - CheckSymbol objCode.Value.Item(1) - 'MsgBox 2 - objEnv.Add objCode.Value.Item(1).Value, _ - Evaluate(objCode.Value.Item(2), objEnv) - 'MsgBox 3 - Set Evaluate = objEnv.Get(objCode.Value.Item(1).Value) - Case "let*" - Dim objNewEnv - Set objNewEnv = New Environment - objNewEnv.SetSelf objNewEnv - objNewEnv.SetOuter objEnv - CheckArgNum objCode, 2 - CheckListOrVector objCode.Value.Item(1) - CheckEven objCode.Value.Item(1).Value.Count - With objCode.Value.Item(1).Value - For i = 0 To .Count - 1 Step 2 - CheckSymbol .Item(i) - objNewEnv.Add .Item(i).Value, _ - Evaluate(.Item(i + 1), objNewEnv) - Next - End With - Set Evaluate = Evaluate(objCode.Value.Item(2), objNewEnv) - End Select - Else - Set Evaluate = objSymbol(EvaluateAST(objCode, objEnv)) - End If + Set objCode.Item(0) = Evaluate(objCode.Item(0), objEnv) + Set varRet = objCode.Item(0).Apply(objCode, objEnv) Else - Set Evaluate = EvaluateAST(objCode, objEnv) + Set varRet = EvaluateAST(objCode, objEnv) End If + + Set Evaluate = varRet End Function -Sub CheckEven(lngNum) - If lngNum Mod 2 <> 0 Then - boolError = True - strError = "not a even number" - Call REPL() - End If -End Sub - -Sub CheckList(objMal) - If objMal.Type <> TYPE_LIST Then - boolError = True - strError = "neither a list nor a vector" - Call REPL() - End If -End Sub - -Sub CheckListOrVector(objMal) - If objMal.Type <> TYPE_LIST And objMal.Type <> TYPE_VECTOR Then - boolError = True - strError = "not a list" - Call REPL() - End If -End Sub - -Sub CheckSymbol(objMal) - If objMal.Type <> TYPE_SYMBOL Then - boolError = True - strError = "not a symbol" - Call REPL() - End If -End Sub Function EvaluateAST(objCode, objEnv) - If TypeName(objCode) = "Nothing" Then - MsgBox "Nothing2" - End If - - Dim objResult, i + Dim varRet, i Select Case objCode.Type - Case TYPE_SYMBOL - Select Case objCode.Value - Case "def!" - Set objResult = objCode - Case "let*" - Set objResult = objCode - Case Else - Set objResult = objEnv.Get(objCode.Value) - End Select - Case TYPE_LIST - For i = 0 To objCode.Value.Count - 1 - Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + For i = 0 To objCode.Count() - 1 + Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) Next - Set objResult = objCode - Case TYPE_VECTOR - For i = 0 To objCode.Value.Count - 1 - Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) + Set varRet = objCode + Case TYPES.HASHMAP + For Each i In objCode.Keys() + Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) Next - Set objResult = objCode - Case TYPE_HASHMAP - Dim arrKeys - arrKeys = objCode.Value.Keys - For i = 0 To objCode.Value.Count - 1 - Set objCode.Value.Item(arrKeys(i)) = _ - Evaluate(objCode.Value.Item(arrKeys(i)), objEnv) - Next - Set objResult = objCode + Set varRet = objCode Case Else - Set objResult = objCode + Set varRet = objCode End Select - Set EvaluateAST = objResult + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + For i = 1 To objCode.Count() - 1 + Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) + Next + Set varRet = objCode + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet End Function Function Print(objCode) @@ -210,4 +190,154 @@ Sub Include(strFileName) .GetFile(WScript.ScriptFullName)) & _ "\" & strFileName).ReadAll End With -End Sub \ No newline at end of file +End Sub + + + + + + + + +' Function Read(strCode) +' Set Read = ReadString(strCode) +' End Function + +' Function Evaluate(objCode, objEnv) +' Dim i +' If TypeName(objCode) = "Nothing" Then +' Call REPL() +' End If + +' If objCode.Type = TYPE_LIST Then +' If objCode.Value.Count = 0 Then +' Set Evaluate = objCode +' Exit Function +' End If + +' Dim objSymbol +' Set objSymbol = Evaluate(objCode.Value.Item(0), objEnv) +' If TypeName(objSymbol) = "MalType" Then +' 'MsgBox TypeName(objCode.value) +' Select Case objSymbol.Value +' Case "def!" +' CheckArgNum objCode, 2 +' CheckSymbol objCode.Value.Item(1) +' 'MsgBox 2 +' objEnv.Add objCode.Value.Item(1).Value, _ +' Evaluate(objCode.Value.Item(2), objEnv) +' 'MsgBox 3 +' Set Evaluate = objEnv.Get(objCode.Value.Item(1).Value) +' Case "let*" +' Dim objNewEnv +' Set objNewEnv = New Environment +' objNewEnv.SetSelf objNewEnv +' objNewEnv.SetOuter objEnv +' CheckArgNum objCode, 2 +' CheckListOrVector objCode.Value.Item(1) +' CheckEven objCode.Value.Item(1).Value.Count +' With objCode.Value.Item(1).Value +' For i = 0 To .Count - 1 Step 2 +' CheckSymbol .Item(i) +' objNewEnv.Add .Item(i).Value, _ +' Evaluate(.Item(i + 1), objNewEnv) +' Next +' End With +' Set Evaluate = Evaluate(objCode.Value.Item(2), objNewEnv) +' End Select +' Else +' Set Evaluate = objSymbol(EvaluateAST(objCode, objEnv)) +' End If +' Else +' Set Evaluate = EvaluateAST(objCode, objEnv) +' End If +' End Function + +' Sub CheckEven(lngNum) +' If lngNum Mod 2 <> 0 Then +' boolError = True +' strError = "not a even number" +' Call REPL() +' End If +' End Sub + +' Sub CheckList(objMal) +' If objMal.Type <> TYPE_LIST Then +' boolError = True +' strError = "neither a list nor a vector" +' Call REPL() +' End If +' End Sub + +' Sub CheckListOrVector(objMal) +' If objMal.Type <> TYPE_LIST And objMal.Type <> TYPE_VECTOR Then +' boolError = True +' strError = "not a list" +' Call REPL() +' End If +' End Sub + +' Sub CheckSymbol(objMal) +' If objMal.Type <> TYPE_SYMBOL Then +' boolError = True +' strError = "not a symbol" +' Call REPL() +' End If +' End Sub + +' Function EvaluateAST(objCode, objEnv) +' If TypeName(objCode) = "Nothing" Then +' MsgBox "Nothing2" +' End If + +' Dim objResult, i +' Select Case objCode.Type +' Case TYPE_SYMBOL +' Select Case objCode.Value +' Case "def!" +' Set objResult = objCode +' Case "let*" +' Set objResult = objCode +' Case Else +' Set objResult = objEnv.Get(objCode.Value) +' End Select +' Case TYPE_LIST +' For i = 0 To objCode.Value.Count - 1 +' Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) +' Next +' Set objResult = objCode +' Case TYPE_VECTOR +' For i = 0 To objCode.Value.Count - 1 +' Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) +' Next +' Set objResult = objCode +' Case TYPE_HASHMAP +' Dim arrKeys +' arrKeys = objCode.Value.Keys +' For i = 0 To objCode.Value.Count - 1 +' Set objCode.Value.Item(arrKeys(i)) = _ +' Evaluate(objCode.Value.Item(arrKeys(i)), objEnv) +' Next +' Set objResult = objCode +' Case Else +' Set objResult = objCode +' End Select +' Set EvaluateAST = objResult +' 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 \ No newline at end of file From ae0886dff25b9b857b157b92233abd37ec36d9c9 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Thu, 19 Jan 2023 23:05:05 +0800 Subject: [PATCH 24/44] rewrite step4 1 --- impls/vbs/printer.vbs | 2 - impls/vbs/step2_eval.vbs | 15 + impls/vbs/step3_env.vbs | 160 +------ impls/vbs/step4_if_fn_do.vbs | 834 +++++++++++++++++++++++------------ impls/vbs/types.vbs | 83 +++- 5 files changed, 634 insertions(+), 460 deletions(-) diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs index 84b13c7f..a01fa97c 100644 --- a/impls/vbs/printer.vbs +++ b/impls/vbs/printer.vbs @@ -68,8 +68,6 @@ Function PrintMalType(objMal, boolReadable) varResult = "nil" Case TYPES.NUMBER varResult = CStr(objMal.Value) - Case TYPES.LAMBDA - varResult = "#" Case TYPES.PROCEDURE varResult = "#" Case TYPES.KEYWORD diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs index ad5c16bc..7dace04f 100644 --- a/impls/vbs/step2_eval.vbs +++ b/impls/vbs/step2_eval.vbs @@ -40,6 +40,8 @@ Set objEnv.Self = objEnv Function Add(objArgs) CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER Set Add = NewMalNum( _ objArgs.Item(1).Value + objArgs.Item(2).Value) End Function @@ -47,6 +49,8 @@ objEnv.Add NewMalSym("+"), NewVbsProc("Add", False) Function [Sub](objArgs) CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER Set [Sub] = NewMalNum( _ objArgs.Item(1).Value - objArgs.Item(2).Value) End Function @@ -54,6 +58,8 @@ objEnv.Add NewMalSym("-"), NewVbsProc("Sub", False) Function Mul(objArgs) CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER Set Mul = NewMalNum( _ objArgs.Item(1).Value * objArgs.Item(2).Value) End Function @@ -61,6 +67,8 @@ objEnv.Add NewMalSym("*"), NewVbsProc("Mul", False) Function Div(objArgs) CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER Set Div = NewMalNum( _ objArgs.Item(1).Value \ objArgs.Item(2).Value) End Function @@ -73,6 +81,13 @@ Sub CheckArgNum(objArgs, lngArgNum) 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 diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs index 1d876bfd..8e7f0dc7 100644 --- a/impls/vbs/step3_env.vbs +++ b/impls/vbs/step3_env.vbs @@ -10,6 +10,8 @@ Set objEnv = NewEnv(Nothing) Function MAdd(objArgs) 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 @@ -17,6 +19,8 @@ objEnv.Add NewMalSym("+"), NewVbsProc("MAdd", False) Function MSub(objArgs) 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 @@ -24,6 +28,8 @@ objEnv.Add NewMalSym("-"), NewVbsProc("MSub", False) Function MMul(objArgs) 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 @@ -31,6 +37,8 @@ objEnv.Add NewMalSym("*"), NewVbsProc("MMul", False) Function MDiv(objArgs) 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 @@ -190,154 +198,4 @@ Sub Include(strFileName) .GetFile(WScript.ScriptFullName)) & _ "\" & strFileName).ReadAll End With -End Sub - - - - - - - - -' Function Read(strCode) -' Set Read = ReadString(strCode) -' End Function - -' Function Evaluate(objCode, objEnv) -' Dim i -' If TypeName(objCode) = "Nothing" Then -' Call REPL() -' End If - -' If objCode.Type = TYPE_LIST Then -' If objCode.Value.Count = 0 Then -' Set Evaluate = objCode -' Exit Function -' End If - -' Dim objSymbol -' Set objSymbol = Evaluate(objCode.Value.Item(0), objEnv) -' If TypeName(objSymbol) = "MalType" Then -' 'MsgBox TypeName(objCode.value) -' Select Case objSymbol.Value -' Case "def!" -' CheckArgNum objCode, 2 -' CheckSymbol objCode.Value.Item(1) -' 'MsgBox 2 -' objEnv.Add objCode.Value.Item(1).Value, _ -' Evaluate(objCode.Value.Item(2), objEnv) -' 'MsgBox 3 -' Set Evaluate = objEnv.Get(objCode.Value.Item(1).Value) -' Case "let*" -' Dim objNewEnv -' Set objNewEnv = New Environment -' objNewEnv.SetSelf objNewEnv -' objNewEnv.SetOuter objEnv -' CheckArgNum objCode, 2 -' CheckListOrVector objCode.Value.Item(1) -' CheckEven objCode.Value.Item(1).Value.Count -' With objCode.Value.Item(1).Value -' For i = 0 To .Count - 1 Step 2 -' CheckSymbol .Item(i) -' objNewEnv.Add .Item(i).Value, _ -' Evaluate(.Item(i + 1), objNewEnv) -' Next -' End With -' Set Evaluate = Evaluate(objCode.Value.Item(2), objNewEnv) -' End Select -' Else -' Set Evaluate = objSymbol(EvaluateAST(objCode, objEnv)) -' End If -' Else -' Set Evaluate = EvaluateAST(objCode, objEnv) -' End If -' End Function - -' Sub CheckEven(lngNum) -' If lngNum Mod 2 <> 0 Then -' boolError = True -' strError = "not a even number" -' Call REPL() -' End If -' End Sub - -' Sub CheckList(objMal) -' If objMal.Type <> TYPE_LIST Then -' boolError = True -' strError = "neither a list nor a vector" -' Call REPL() -' End If -' End Sub - -' Sub CheckListOrVector(objMal) -' If objMal.Type <> TYPE_LIST And objMal.Type <> TYPE_VECTOR Then -' boolError = True -' strError = "not a list" -' Call REPL() -' End If -' End Sub - -' Sub CheckSymbol(objMal) -' If objMal.Type <> TYPE_SYMBOL Then -' boolError = True -' strError = "not a symbol" -' Call REPL() -' End If -' End Sub - -' Function EvaluateAST(objCode, objEnv) -' If TypeName(objCode) = "Nothing" Then -' MsgBox "Nothing2" -' End If - -' Dim objResult, i -' Select Case objCode.Type -' Case TYPE_SYMBOL -' Select Case objCode.Value -' Case "def!" -' Set objResult = objCode -' Case "let*" -' Set objResult = objCode -' Case Else -' Set objResult = objEnv.Get(objCode.Value) -' End Select -' Case TYPE_LIST -' For i = 0 To objCode.Value.Count - 1 -' Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) -' Next -' Set objResult = objCode -' Case TYPE_VECTOR -' For i = 0 To objCode.Value.Count - 1 -' Set objCode.Value.Item(i) = Evaluate(objCode.Value.Item(i), objEnv) -' Next -' Set objResult = objCode -' Case TYPE_HASHMAP -' Dim arrKeys -' arrKeys = objCode.Value.Keys -' For i = 0 To objCode.Value.Count - 1 -' Set objCode.Value.Item(arrKeys(i)) = _ -' Evaluate(objCode.Value.Item(arrKeys(i)), objEnv) -' Next -' Set objResult = objCode -' Case Else -' Set objResult = objCode -' End Select -' Set EvaluateAST = objResult -' 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 \ No newline at end of file +End Sub \ No newline at end of file diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs index 0fc5a1c7..fad64cb2 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -1,76 +1,173 @@ -'TODO ×Ö·û´®ÓÐÎÊÌâ - Option Explicit -Dim DEPTH -DEPTH = 0 -Dim CALLFROM -CALLFROM = "" -Include "Core.vbs" + +Include "Types.vbs" Include "Reader.vbs" Include "Printer.vbs" Include "Env.vbs" -Dim objRootEnv -Set objRootEnv = New Environment -objRootEnv.SetSelf objRootEnv -objRootEnv.SetOuter Nothing -Dim arrKeys, i -arrKeys = objCoreNS.Keys -For i = 0 To UBound(arrKeys) - objRootEnv.Add arrKeys(i), NewLambda(objCoreNS.Item(arrKeys(i))) -Next -objRootEnv.Add "def!", NewSpecialForm("def!") -objRootEnv.Add "let*", NewSpecialForm("let*") -objRootEnv.Add "do", NewSpecialForm("do") -objRootEnv.Add "if", NewSpecialForm("if") -objRootEnv.Add "fn*", NewSpecialForm("fn*") -REP "(def! not (fn* (a) (if a false true)))" +Dim objEnv +Set objEnv = NewEnv(Nothing) -Function NewLambda(objFunction) - Dim objMal - Set objMal = New MalType - Set objMal.Value = New BuiltInFunction - Set objMal.Value.Run = objFunction - objMal.Type = TYPE_LAMBDA - Set NewLambda = objMal +Function MAdd(objArgs) + 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 NewSpecialForm(strValue) - Set NewSpecialForm = New MalType - NewSpecialForm.Value = strValue - NewSpecialForm.Type = TYPE_SPECIAL +Function MSub(objArgs) + 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 IsSpecialForm(objForm) - IsSpecialForm = (objForm.Type = TYPE_SPECIAL) +Function MMul(objArgs) + 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) -Class SpecialForm - Public Value -End Class +Function MDiv(objArgs) + 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, lngExpect) - If objArgs.Value.Count - 1 <> lngExpect Then - boolError = True - strError = "wrong number of arguments" - Call REPL() - End If +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) + +Function MDo(objArgs, objEnv) + Dim varRet, i + For i = 1 To objArgs.Count - 1 + Set varRet = Evaluate(objArgs.Item(i), objEnv) + Next + Set MDo = varRet +End Function +objEnv.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 + + If Evaluate(objArgs.Item(1), objEnv).Value 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 +objEnv.Add NewMalSym("if"), NewVbsProc("MIf", True) + +Function MFn(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objParams, objCode + Set objParams = objArgs.Item(1) + Set objCode = objArgs.Item(2) + If objParams.Type <> TYPES.LIST And _ + objParams.Type <> TYPES.VECTOR Then + Err.Raise vbObjectError, _ + "MFn", "Wrong argument type." + End If + + 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 +objEnv.Add NewMalSym("fn*"), NewVbsProc("MFn", True) + Call REPL() Sub REPL() Dim strCode, strResult While True - If boolError Then - WScript.StdErr.WriteLine "ERROR: " & strError - boolError = False - End If WScript.StdOut.Write("user> ") + On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + 'On Error Resume Next + WScript.Echo REP(strCode) + If Err.Number <> 0 Then + WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + End If On Error Goto 0 - WScript.Echo REP(strCode) Wend End Sub @@ -78,262 +175,64 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function - -Function Evaluate(objCode, objEnv) - DEPTH = DEPTH + 1 - Dim i +Function Evaluate(objCode, objEnv) ' Return Nothing / objCode If TypeName(objCode) = "Nothing" Then - Call REPL() + Set Evaluate = Nothing + Exit Function End If - - If objCode.Type = TYPE_LIST Then - If objCode.Value.Count = 0 Then + Dim varRet + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () Set Evaluate = objCode Exit Function End If - - Dim objSymbol - 'wsh.echo space(DEPTH*4)&"CHECK FIRST" - Set objSymbol = Evaluate(objCode.Value.Item(0), objEnv) - 'wsh.echo space(DEPTH*4)&"CHECK FIRST FINISH" - 'MsgBox objSymbol.type - If IsSpecialForm(objSymbol) Then - 'wsh.echo space(DEPTH*4)&"EVAL SPECIAL" - 'MsgBox TypeName(objCode.value) - Select Case objSymbol.Value - Case "def!" - 'MsgBox "ÎÒÔÚdef" - CheckArgNum objCode, 2 - CheckSymbol objCode.Value.Item(1) - objEnv.Add objCode.Value.Item(1).Value, _ - Evaluate(objCode.Value.Item(2), objEnv) - Set Evaluate = objEnv.Get(objCode.Value.Item(1).Value) - Case "let*" - Dim objNewEnv - Set objNewEnv = New Environment - objNewEnv.SetSelf objNewEnv - objNewEnv.SetOuter objEnv - CheckArgNum objCode, 2 - CheckListOrVector objCode.Value.Item(1) - CheckEven objCode.Value.Item(1).Value.Count - With objCode.Value.Item(1).Value - For i = 0 To .Count - 1 Step 2 - CheckSymbol .Item(i) - objNewEnv.Add .Item(i).Value, _ - Evaluate(.Item(i + 1), objNewEnv) - Next - End With - Set Evaluate = Evaluate(objCode.Value.Item(2), objNewEnv) - Case "do" - Set Evaluate = EvaluateAST(objCode, objEnv) - Set Evaluate = Evaluate.Value.Item(Evaluate.Value.Count - 1) - Case "if" - Dim objCondition - 'MsgBox 1 - Set objCondition = Evaluate(objCode.Value.Item(1), objEnv) - 'MsgBox 2 - 'MsgBox IsNil(objCondition) - 'MsgBox IsFalse(objCondition) - If IsNil(objCondition) Or IsFalse(objCondition) Then - 'MsgBox 1 - Select Case objCode.Value.Count - 1 - Case 2 - Set Evaluate = New MalType - Evaluate.Type = TYPE_NIL - Case 3 - Set Evaluate = Evaluate(objCode.Value.Item(3), objEnv) - Case Else - 'TODO Err - End Select - Else - If objCode.Value.Count - 1 = 2 Or objCode.Value.Count - 1 = 3 Then - Set Evaluate = Evaluate(objCode.Value.Item(2), objEnv) - Else - 'TODO err - End If - End If - Case "fn*" 'lambda - CheckArgNum objCode, 2 - Set Evaluate = New MalType - Evaluate.Type = TYPE_LAMBDA - Set Evaluate.Value = New Lambda - 'MsgBox 1 - Set Evaluate.Value.objEnv = New Environment - Evaluate.Value.objEnv.SetSelf Evaluate.Value.objEnv - Evaluate.Value.objEnv.SetOuter objEnv - Set Evaluate.Value.objParameters = objCode.Value.Item(1) - Set Evaluate.Value.objBody = objCode.Value.Item(2) - 'MsgBox 1 - End Select - 'wsh.echo space(DEPTH*4)&"EVAL SPECIAL FINISH" - Else - 'wsh.echo space(DEPTH*4)&"EVAL NORMAL" - 'MsgBox 2 - 'objSymbol.Value.SetEnv objEnv - 'wsh.echo space(DEPTH*4)&"objcode","type",objCode.Type - 'If objCode.Type = 7 Then wsh.echo space(DEPTH*4)&objCode.value - 'If objCode.Type = 8 Then wsh.echo space(DEPTH*4)&objCode.value - 'If objCode.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(objCode,True) - - 'ÕâÀïÓдóÎÊÌâ - If objSymbol.Value.IsBuiltIn Then - dim oldenv - set oldenv = objSymbol.Value.objEnv - Set objSymbol.Value.objEnv = objEnv - objSymbol.Value.objEnv.SetSelf objSymbol.Value.objEnv - objSymbol.Value.objEnv.SetOuter oldEnv - Set Evaluate = objSymbol.Value.Run(objCode) - - Else - Set Evaluate = objSymbol.Value.Run(EvaluateAST(objCode, objEnv)) - End If - 'wsh.echo space(DEPTH*4)&"evaluate","type",Evaluate.Type - 'If Evaluate.Type = 7 Then wsh.echo space(DEPTH*4)&Evaluate.value - 'If Evaluate.Type = 8 Then wsh.echo space(DEPTH*4)&Evaluate.value - 'If Evaluate.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(Evaluate,True) - 'Set Evaluate = Evaluate(objCode, objEnv) - 'MsgBox Evaluate.type - 'MsgBox objEnv.Get("N").value - 'MsgBox 3 - 'wsh.echo space(DEPTH*4)&"EVAL NORMAL FINISH" - End If + Set objCode.Item(0) = Evaluate(objCode.Item(0), objEnv) + Set varRet = objCode.Item(0).Apply(objCode, objEnv) Else - 'wsh.echo space(DEPTH*4)&"objcode","type",objCode.Type - 'If objCode.Type = 7 Then wsh.echo space(DEPTH*4)&objCode.value - 'If objCode.Type = 8 Then wsh.echo space(DEPTH*4)&objCode.value - 'If objCode.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(objCode,True) - Set Evaluate = EvaluateAST(objCode, objEnv) - 'wsh.echo space(DEPTH*4)&"evaluate","type",Evaluate.Type - 'If Evaluate.Type = 7 Then wsh.echo space(DEPTH*4)&Evaluate.value - 'If Evaluate.Type = 8 Then wsh.echo space(DEPTH*4)&Evaluate.value - 'If Evaluate.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(Evaluate,True) - 'wsh.echo "" + Set varRet = EvaluateAST(objCode, objEnv) End If - 'wsh.echo space(DEPTH*4)&"RETURN" - DEPTH = DEPTH - 1 + + Set Evaluate = varRet End Function -Class BuiltInFunction - Public IsBuiltIn - Public Sub Class_Initialize - IsBuiltIn = False - End Sub - Public Run - Public Sub SetEnv(z) - End Sub -End Class - -Class Lambda - Public objParameters - Public objBody - Public objEnv - Public IsBuiltIn - Public Sub Class_Initialize - IsBuiltIn = True - End Sub - Public Function SetEnv(oInv) - Set objEnv=oInv - End Function - - Public Function Run(objArgs) - Dim objNewEnv - Set objNewEnv = New Environment - objNewEnv.SetSelf objNewEnv - objNewEnv.SetOuter objEnv - 'MsgBox objArgs.type - objNewEnv.Init objParameters, objArgs - 'para start from 0, args start from 1 - 'MsgBox objNewEnv.Get("N").value - 'wsh.echo space(DEPTH*4)&"RUN "& PrintMalType(objBody,True) - Set Run = Evaluate(objBody, objNewEnv) - 'wsh.echo space(DEPTH*4)&"RUN FINISH" - 'MsgBox Run.type - 'MsgBox Run.value - End Function -End Class - -Function IsZero(objMal) - IsZero = (objMal.Type = TYPE_NUMBER And objMal.Value = 0) - 'MsgBox IsZero -End Function - -Function IsFalse(objMal) - IsFalse = (objMal.Type = TYPE_BOOLEAN) - If Not IsFalse Then Exit Function - IsFalse = IsFalse And (objMal.Value = False) -End Function - -Function IsNil(objMal) - IsNil = (objMal.Type = TYPE_NIL) -End Function - -Sub CheckEven(lngNum) - If lngNum Mod 2 <> 0 Then - boolError = True - strError = "not a even number" - Call REPL() - End If -End Sub - -Sub CheckList(objMal) - If objMal.Type <> TYPE_LIST Then - boolError = True - strError = "neither a list nor a vector" - Call REPL() - End If -End Sub - -Sub CheckListOrVector(objMal) - If objMal.Type <> TYPE_LIST And objMal.Type <> TYPE_VECTOR Then - boolError = True - strError = "not a list" - Call REPL() - End If -End Sub - -Sub CheckSymbol(objMal) - If objMal.Type <> TYPE_SYMBOL Then - boolError = True - strError = "not a symbol" - Call REPL() - End If -End Sub Function EvaluateAST(objCode, objEnv) - If TypeName(objCode) = "Nothing" Then - MsgBox "Nothing2" - End If - - Dim objResult, i + Dim varRet, i Select Case objCode.Type - Case TYPE_SYMBOL - Set objResult = objEnv.Get(objCode.Value) - Case TYPE_LIST - Set objResult = New MalType - Set objResult.Value = CreateObject("System.Collections.ArrayList") - objResult.Type = TYPE_LIST - For i = 0 To objCode.Value.Count - 1 - objResult.Value.Add Evaluate(objCode.Value.Item(i), objEnv) + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + For i = 0 To objCode.Count() - 1 + Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) Next - Case TYPE_VECTOR - Set objResult = New MalType - Set objResult.Value = CreateObject("System.Collections.ArrayList") - objResult.Type = TYPE_VECTOR - For i = 0 To objCode.Value.Count - 1 - objResult.Value.Add Evaluate(objCode.Value.Item(i), objEnv) - Next - Case TYPE_HASHMAP - Set objResult = New MalType - Set objResult.Value = CreateObject("Scripting.Dictionary") - objResult.Type = TYPE_HASHMAP - Dim key - For Each key In objCode.Value.Keys - objResult.Value.Add Evaluate(key, objEnv), Evaluate(objCode.Value.Item(key), objEnv) + Set varRet = objCode + Case TYPES.HASHMAP + For Each i In objCode.Keys() + Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) Next + Set varRet = objCode Case Else - Set objResult = objCode + Set varRet = objCode End Select - Set EvaluateAST = objResult + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + For i = 1 To objCode.Count() - 1 + Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) + Next + Set varRet = objCode + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet End Function Function Print(objCode) @@ -341,7 +240,7 @@ Function Print(objCode) End Function Function REP(strCode) - REP = Print(Evaluate(Read(strCode), objRootEnv)) + REP = Print(Evaluate(Read(strCode), objEnv)) End Function Sub Include(strFileName) @@ -352,3 +251,354 @@ Sub Include(strFileName) "\" & strFileName).ReadAll End With End Sub + + + + + + + + + +' Dim objRootEnv +' Set objRootEnv = New Environment +' objRootEnv.SetSelf objRootEnv +' objRootEnv.SetOuter Nothing +' Dim arrKeys, i +' arrKeys = objCoreNS.Keys +' For i = 0 To UBound(arrKeys) +' objRootEnv.Add arrKeys(i), NewLambda(objCoreNS.Item(arrKeys(i))) +' Next +' objRootEnv.Add "def!", NewSpecialForm("def!") +' objRootEnv.Add "let*", NewSpecialForm("let*") +' objRootEnv.Add "do", NewSpecialForm("do") +' objRootEnv.Add "if", NewSpecialForm("if") +' objRootEnv.Add "fn*", NewSpecialForm("fn*") +' REP "(def! not (fn* (a) (if a false true)))" + +' Function NewLambda(objFunction) +' Dim objMal +' Set objMal = New MalType +' Set objMal.Value = New BuiltInFunction +' Set objMal.Value.Run = objFunction +' objMal.Type = TYPE_LAMBDA +' Set NewLambda = objMal +' End Function + +' Function NewSpecialForm(strValue) +' Set NewSpecialForm = New MalType +' NewSpecialForm.Value = strValue +' NewSpecialForm.Type = TYPE_SPECIAL +' End Function + +' Function IsSpecialForm(objForm) +' IsSpecialForm = (objForm.Type = TYPE_SPECIAL) +' End Function + +' Class SpecialForm +' Public Value +' End Class + +' Sub CheckArgNum(objArgs, lngExpect) +' If objArgs.Value.Count - 1 <> lngExpect Then +' boolError = True +' strError = "wrong number of arguments" +' Call REPL() +' End If +' End Sub + +' Call REPL() +' Sub REPL() +' Dim strCode, strResult +' While True +' If boolError Then +' WScript.StdErr.WriteLine "ERROR: " & strError +' boolError = False +' End If +' 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 +' End Sub + +' Function Read(strCode) +' Set Read = ReadString(strCode) +' End Function + + +' Function Evaluate(objCode, objEnv) +' DEPTH = DEPTH + 1 +' Dim i +' If TypeName(objCode) = "Nothing" Then +' Call REPL() +' End If + +' If objCode.Type = TYPE_LIST Then +' If objCode.Value.Count = 0 Then +' Set Evaluate = objCode +' Exit Function +' End If + +' Dim objSymbol +' 'wsh.echo space(DEPTH*4)&"CHECK FIRST" +' Set objSymbol = Evaluate(objCode.Value.Item(0), objEnv) +' 'wsh.echo space(DEPTH*4)&"CHECK FIRST FINISH" +' 'MsgBox objSymbol.type +' If IsSpecialForm(objSymbol) Then +' 'wsh.echo space(DEPTH*4)&"EVAL SPECIAL" +' 'MsgBox TypeName(objCode.value) +' Select Case objSymbol.Value +' Case "def!" +' 'MsgBox "����def" +' CheckArgNum objCode, 2 +' CheckSymbol objCode.Value.Item(1) +' objEnv.Add objCode.Value.Item(1).Value, _ +' Evaluate(objCode.Value.Item(2), objEnv) +' Set Evaluate = objEnv.Get(objCode.Value.Item(1).Value) +' Case "let*" +' Dim objNewEnv +' Set objNewEnv = New Environment +' objNewEnv.SetSelf objNewEnv +' objNewEnv.SetOuter objEnv +' CheckArgNum objCode, 2 +' CheckListOrVector objCode.Value.Item(1) +' CheckEven objCode.Value.Item(1).Value.Count +' With objCode.Value.Item(1).Value +' For i = 0 To .Count - 1 Step 2 +' CheckSymbol .Item(i) +' objNewEnv.Add .Item(i).Value, _ +' Evaluate(.Item(i + 1), objNewEnv) +' Next +' End With +' Set Evaluate = Evaluate(objCode.Value.Item(2), objNewEnv) +' Case "do" +' Set Evaluate = EvaluateAST(objCode, objEnv) +' Set Evaluate = Evaluate.Value.Item(Evaluate.Value.Count - 1) +' Case "if" +' Dim objCondition +' 'MsgBox 1 +' Set objCondition = Evaluate(objCode.Value.Item(1), objEnv) +' 'MsgBox 2 +' 'MsgBox IsNil(objCondition) +' 'MsgBox IsFalse(objCondition) +' If IsNil(objCondition) Or IsFalse(objCondition) Then +' 'MsgBox 1 +' Select Case objCode.Value.Count - 1 +' Case 2 +' Set Evaluate = New MalType +' Evaluate.Type = TYPE_NIL +' Case 3 +' Set Evaluate = Evaluate(objCode.Value.Item(3), objEnv) +' Case Else +' 'TODO Err +' End Select +' Else +' If objCode.Value.Count - 1 = 2 Or objCode.Value.Count - 1 = 3 Then +' Set Evaluate = Evaluate(objCode.Value.Item(2), objEnv) +' Else +' 'TODO err +' End If +' End If +' Case "fn*" 'lambda +' CheckArgNum objCode, 2 +' Set Evaluate = New MalType +' Evaluate.Type = TYPE_LAMBDA +' Set Evaluate.Value = New Lambda +' 'MsgBox 1 +' Set Evaluate.Value.objEnv = New Environment +' Evaluate.Value.objEnv.SetSelf Evaluate.Value.objEnv +' Evaluate.Value.objEnv.SetOuter objEnv +' Set Evaluate.Value.objParameters = objCode.Value.Item(1) +' Set Evaluate.Value.objBody = objCode.Value.Item(2) +' 'MsgBox 1 +' End Select +' 'wsh.echo space(DEPTH*4)&"EVAL SPECIAL FINISH" +' Else +' 'wsh.echo space(DEPTH*4)&"EVAL NORMAL" +' 'MsgBox 2 +' 'objSymbol.Value.SetEnv objEnv +' 'wsh.echo space(DEPTH*4)&"objcode","type",objCode.Type +' 'If objCode.Type = 7 Then wsh.echo space(DEPTH*4)&objCode.value +' 'If objCode.Type = 8 Then wsh.echo space(DEPTH*4)&objCode.value +' 'If objCode.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(objCode,True) + +' '��������� +' If objSymbol.Value.IsBuiltIn Then +' dim oldenv +' set oldenv = objSymbol.Value.objEnv +' Set objSymbol.Value.objEnv = objEnv +' objSymbol.Value.objEnv.SetSelf objSymbol.Value.objEnv +' objSymbol.Value.objEnv.SetOuter oldEnv +' Set Evaluate = objSymbol.Value.Run(objCode) + +' Else +' Set Evaluate = objSymbol.Value.Run(EvaluateAST(objCode, objEnv)) +' End If +' 'wsh.echo space(DEPTH*4)&"evaluate","type",Evaluate.Type +' 'If Evaluate.Type = 7 Then wsh.echo space(DEPTH*4)&Evaluate.value +' 'If Evaluate.Type = 8 Then wsh.echo space(DEPTH*4)&Evaluate.value +' 'If Evaluate.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(Evaluate,True) +' 'Set Evaluate = Evaluate(objCode, objEnv) +' 'MsgBox Evaluate.type +' 'MsgBox objEnv.Get("N").value +' 'MsgBox 3 +' 'wsh.echo space(DEPTH*4)&"EVAL NORMAL FINISH" +' End If +' Else +' 'wsh.echo space(DEPTH*4)&"objcode","type",objCode.Type +' 'If objCode.Type = 7 Then wsh.echo space(DEPTH*4)&objCode.value +' 'If objCode.Type = 8 Then wsh.echo space(DEPTH*4)&objCode.value +' 'If objCode.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(objCode,True) +' Set Evaluate = EvaluateAST(objCode, objEnv) +' 'wsh.echo space(DEPTH*4)&"evaluate","type",Evaluate.Type +' 'If Evaluate.Type = 7 Then wsh.echo space(DEPTH*4)&Evaluate.value +' 'If Evaluate.Type = 8 Then wsh.echo space(DEPTH*4)&Evaluate.value +' 'If Evaluate.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(Evaluate,True) +' 'wsh.echo "" +' End If +' 'wsh.echo space(DEPTH*4)&"RETURN" +' DEPTH = DEPTH - 1 +' End Function + +' Class BuiltInFunction +' Public IsBuiltIn +' Public Sub Class_Initialize +' IsBuiltIn = False +' End Sub +' Public Run +' Public Sub SetEnv(z) +' End Sub +' End Class + +' Class Lambda +' Public objParameters +' Public objBody +' Public objEnv +' Public IsBuiltIn +' Public Sub Class_Initialize +' IsBuiltIn = True +' End Sub +' Public Function SetEnv(oInv) +' Set objEnv=oInv +' End Function + +' Public Function Run(objArgs) +' Dim objNewEnv +' Set objNewEnv = New Environment +' objNewEnv.SetSelf objNewEnv +' objNewEnv.SetOuter objEnv +' 'MsgBox objArgs.type +' objNewEnv.Init objParameters, objArgs +' 'para start from 0, args start from 1 +' 'MsgBox objNewEnv.Get("N").value +' 'wsh.echo space(DEPTH*4)&"RUN "& PrintMalType(objBody,True) +' Set Run = Evaluate(objBody, objNewEnv) +' 'wsh.echo space(DEPTH*4)&"RUN FINISH" +' 'MsgBox Run.type +' 'MsgBox Run.value +' End Function +' End Class + +' Function IsZero(objMal) +' IsZero = (objMal.Type = TYPE_NUMBER And objMal.Value = 0) +' 'MsgBox IsZero +' End Function + +' Function IsFalse(objMal) +' IsFalse = (objMal.Type = TYPE_BOOLEAN) +' If Not IsFalse Then Exit Function +' IsFalse = IsFalse And (objMal.Value = False) +' End Function + +' Function IsNil(objMal) +' IsNil = (objMal.Type = TYPE_NIL) +' End Function + +' Sub CheckEven(lngNum) +' If lngNum Mod 2 <> 0 Then +' boolError = True +' strError = "not a even number" +' Call REPL() +' End If +' End Sub + +' Sub CheckList(objMal) +' If objMal.Type <> TYPE_LIST Then +' boolError = True +' strError = "neither a list nor a vector" +' Call REPL() +' End If +' End Sub + +' Sub CheckListOrVector(objMal) +' If objMal.Type <> TYPE_LIST And objMal.Type <> TYPE_VECTOR Then +' boolError = True +' strError = "not a list" +' Call REPL() +' End If +' End Sub + +' Sub CheckSymbol(objMal) +' If objMal.Type <> TYPE_SYMBOL Then +' boolError = True +' strError = "not a symbol" +' Call REPL() +' End If +' End Sub + +' Function EvaluateAST(objCode, objEnv) +' If TypeName(objCode) = "Nothing" Then +' MsgBox "Nothing2" +' End If + +' Dim objResult, i +' Select Case objCode.Type +' Case TYPE_SYMBOL +' Set objResult = objEnv.Get(objCode.Value) +' Case TYPE_LIST +' Set objResult = New MalType +' Set objResult.Value = CreateObject("System.Collections.ArrayList") +' objResult.Type = TYPE_LIST +' For i = 0 To objCode.Value.Count - 1 +' objResult.Value.Add Evaluate(objCode.Value.Item(i), objEnv) +' Next +' Case TYPE_VECTOR +' Set objResult = New MalType +' Set objResult.Value = CreateObject("System.Collections.ArrayList") +' objResult.Type = TYPE_VECTOR +' For i = 0 To objCode.Value.Count - 1 +' objResult.Value.Add Evaluate(objCode.Value.Item(i), objEnv) +' Next +' Case TYPE_HASHMAP +' Set objResult = New MalType +' Set objResult.Value = CreateObject("Scripting.Dictionary") +' objResult.Type = TYPE_HASHMAP +' Dim key +' For Each key In objCode.Value.Keys +' objResult.Value.Add Evaluate(key, objEnv), Evaluate(objCode.Value.Item(key), objEnv) +' Next +' Case Else +' Set objResult = objCode +' End Select +' Set EvaluateAST = objResult +' End Function + +' Function Print(objCode) +' Print = PrintMalType(objCode, True) +' End Function + +' Function REP(strCode) +' REP = Print(Evaluate(Read(strCode), objRootEnv)) +' End Function + +' Sub Include(strFileName) +' With CreateObject("Scripting.FileSystemObject") +' ExecuteGlobal .OpenTextFile( _ +' .GetParentFolderName( _ +' .GetFile(WScript.ScriptFullName)) & _ +' "\" & strFileName).ReadAll +' End With +' End Sub diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index 90c7d2f3..53b87c9b 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -6,14 +6,14 @@ Set TYPES = New MalTypes Class MalTypes Public LIST, VECTOR, HASHMAP, [BOOLEAN], NIL Public KEYWORD, [STRING], NUMBER, SYMBOL - Public LAMBDA, PROCEDURE + Public PROCEDURE Public [TypeName] Private Sub Class_Initialize [TypeName] = Array( _ "LIST", "VECTOR", "HASHMAP", "BOOLEAN", _ "NIL", "KEYWORD", "STRING", "NUMBER", _ - "SYMBOL", "LAMBDA", "PROCEDURE") + "SYMBOL", "PROCEDURE") Dim i For i = 0 To UBound([TypeName]) @@ -202,32 +202,26 @@ Function NewMalMap(arrKeys, arrValues) Set NewMalMap = varResult End Function -Class MalProcedure 'Extends MalType +Class VbsProcedure 'Extends MalType Public [Type] Public Value - Public boolBuiltin Public boolSpec Private Sub Class_Initialize [Type] = TYPES.PROCEDURE End Sub - Public Function Init(objFunction, boolIsBuiltin, boolIsSpec) + Public Function Init(objFunction, boolIsSpec) Set Value = objFunction - boolBuiltin = boolIsBuiltin boolSpec = boolIsSpec End Function Public Function Apply(objArgs, objEnv) Dim varResult - If boolBuiltin Then - If boolSpec Then - Set varResult = Value(objArgs, objEnv) - Else - Set varResult = Value(EvaluateRest(objArgs, objEnv)) - End If + If boolSpec Then + Set varResult = Value(objArgs, objEnv) Else - wsh.echo "impl later" + Set varResult = Value(EvaluateRest(objArgs, objEnv)) End If Set Apply = varResult End Function @@ -235,7 +229,66 @@ End Class Function NewVbsProc(strFnName, boolSpec) Dim varResult - Set varResult = New MalProcedure - varResult.Init GetRef(strFnName), True, boolSpec + Set varResult = New VbsProcedure + varResult.Init GetRef(strFnName), boolSpec Set NewVbsProc = varResult +End Function + +Class MalProcedure 'Extends MalType + Public [Type] + Public Value + + Private Sub Class_Initialize + [Type] = TYPES.PROCEDURE + End Sub + + Private 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) + 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, _ + "MalProcedure", "Invalid parameter(s)." + End If + Else + If i + 1 >= objArgs.Count Then + Err.Raise vbObjectError, _ + "MalProcedure", "Need more arguments." + End If + objNewEnv.Add objParams.Item(i), _ + Evaluate(objArgs.Item(i + 1), objEnv) + i = i + 1 + End If + Wend + Set varRet = Evaluate(objCode, objNewEnv) + Set Apply = varRet + 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 \ No newline at end of file From a646c3ee9c28d508c9d6929008e9941c2dca53c9 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Thu, 19 Jan 2023 23:56:35 +0800 Subject: [PATCH 25/44] add some functions --- impls/vbs/core.vbs | 381 ++++++++++--------------------- impls/vbs/env.vbs | 34 --- impls/vbs/step4_if_fn_do.vbs | 420 +---------------------------------- impls/vbs/types.vbs | 1 + 4 files changed, 128 insertions(+), 708 deletions(-) diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index 15512e2d..cf9e92ce 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -1,281 +1,142 @@ -Include "Types.vbs" +Option Explicit -Sub Include(strFileName) - With CreateObject("Scripting.FileSystemObject") - ExecuteGlobal .OpenTextFile( _ - .GetParentFolderName( _ - .GetFile(WScript.ScriptFullName)) & _ - "\" & strFileName).ReadAll - End With +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 -' Public objCoreNS -' Set objCoreNS = CreateObject("Scripting.Dictionary") -' objCoreNS.Add "+", GetRef("Add") -' objCoreNS.Add "-", GetRef("Subtract") -' objCoreNS.Add "*", GetRef("Multiply") -' objCoreNS.Add "/", GetRef("Divide") -' objCoreNS.Add "list", GetRef("mMakeList") -' objCoreNS.Add "list?", GetRef("mIsList") '1 -' objCoreNS.Add "empty?", GetRef("mIsListEmpty") '1 -' objCoreNS.Add "count", GetRef("mListCount") '1 -' objCoreNS.Add "=", GetRef("mEqual") '2 'both type & value -' objCoreNS.Add "<", GetRef("mLess") '2 'number only -' objCoreNS.Add ">", GetRef("mGreater") '2 'number only -' objCoreNS.Add "<=", GetRef("mEqualLess") '2 'number only -' objCoreNS.Add ">=", GetRef("mEqualGreater") '2 'number only -' objCoreNS.Add "pr-str", GetRef("mprstr") 'all 'ret str 'readable 'concat by space -' objCoreNS.Add "str", GetRef("mstr") 'all 'ret str '!readable 'concat by "" -' objCoreNS.Add "prn", GetRef("mprn") 'all 'to screen ret nil 'concat by space 'readable -' objCoreNS.Add "println", GetRef("mprintln") 'all 'to screen ret nil 'concat by space '!readable -' objCoreNS.Add "get", GetRef("mGet") -' objCoreNS.Add "set", GetRef("mSet") -' objCoreNS.Add "first", GetRef("mFirst") -' objCoreNS.Add "last", GetRef("mLast") +Function IsListOrVec(objMal) + IsListOrVec = _ + objMal.Type = TYPES.LIST Or _ + objMal.Type = TYPES.VECTOR +End Function -' Function mLast(objArgs) -' Set objRes = New MalType -' objRes.Type = TYPE_LIST -' set objRes.value = createobject("system.collections.arraylist") -' for i = 1 to objArgs.value.item(1).value.count - 1 -' objRes.value.add objArgs.value.item(1).value.item(i) -' next -' Set mLast= objRes -' 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 -' Function mFirst(objArgs) -' 'Set objRes = New MalType -' Set objRes = objArgs.value.item(1).value.item(0) -' Set mFirst= objRes -' 'msgbox 1 -' End Function +Dim objNS +Set objNS = NewEnv(Nothing) -' Function mGet(objArgs) -' Set objRes = New MalType -' 'objRes.Type = -' Set objList = objArgs.value.item(1) -' numIndex = objArgs.value.item(2).value -' Set objRes = objList.value.Item(numIndex) -' 'MsgBox objRes.type -' Set mGet = objRes -' End Function +Function MAdd(objArgs) + 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 mSet(objArgs) -' Set objRes = New MalType -' 'objRes.Type = -' 'MsgBox 1 -' Set objList = objArgs.value.item(1) -' numIndex = objArgs.value.item(2).value -' 'MsgBox numIndex -' Set objReplace = objArgs.value.item(3) -' Set objList.value.Item(numIndex) = objReplace -' 'MsgBox objRes.type -' Set mSet = New MalType -' mSet.Type = TYPE_NIL -' End Function +Function MSub(objArgs) + 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 mprintln(objArgs) -' Dim objRes,i -' Set objRes = New MalType -' objRes.Type = TYPE_NIL -' For i = 1 To objArgs.Value.Count - 2 -' wsh.stdout.write PrintMalType(objArgs.Value.Item(i), False) & " " -' Next -' If objArgs.Value.Count - 1 > 0 Then -' wsh.stdout.write PrintMalType(objArgs.Value.Item(objArgs.Value.Count - 1), False) -' End If -' Set mprintln=objRes -' End Function +Function MMul(objArgs) + 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 mprn(objArgs) -' Dim objRes,i -' Set objRes = New MalType -' objRes.Type = TYPE_NIL -' For i = 1 To objArgs.Value.Count - 2 -' wsh.stdout.write PrintMalType(objArgs.Value.Item(i), True) & " " -' Next -' If objArgs.Value.Count - 1 > 0 Then -' wsh.stdout.write PrintMalType(objArgs.Value.Item(objArgs.Value.Count - 1), True) -' End If -' Set mprn=objRes -' End Function +Function MDiv(objArgs) + 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 mstr(objArgs) -' Dim objRes,i -' Set objRes = New MalType -' objRes.Type = TYPE_STRING -' objRes.Value = "" -' For i = 1 To objArgs.Value.Count - 1 -' objRes.Value = objRes.Value & PrintMalType(objArgs.Value.Item(i), False) -' Next -' Set mstr=objRes -' End Function +Function MList(objArgs) + 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 mprstr(objArgs) -' Dim objRes,i -' Set objRes = New MalType -' objRes.Type = TYPE_STRING -' objRes.Value = "" -' For i = 1 To objArgs.Value.Count - 2 -' objRes.Value = objRes.Value & PrintMalType(objArgs.Value.Item(i), True) & " " -' Next -' If objArgs.Value.Count - 1 > 0 Then -' objRes.Value = objRes.Value & PrintMalType(objArgs.Value.Item(objArgs.Value.Count - 1), True) -' End If -' Set mprstr=objRes -' End Function +Function MIsList(objArgs) + CheckArgNum objArgs, 1 -' Function mEqualGreater(objArgs) -' CheckArgNum objArgs, 2 -' Dim objRes,i -' Set objRes = New MalType -' objRes.Type = TYPE_BOOLEAN -' objRes.Value = (objArgs.Value.Item(1).Value >= objArgs.Value.Item(2).Value) -' Set mEqualGreater = objRes -' End Function + Set MIsList = NewMalBool(objArgs.Item(1).Type = TYPES.LIST) +End Function +objNS.Add NewMalSym("list?"), NewVbsProc("MIsList", False) -' Function mEqualLess(objArgs) -' CheckArgNum objArgs, 2 -' Dim objRes,i -' Set objRes = New MalType -' objRes.Type = TYPE_BOOLEAN -' objRes.Value = (objArgs.Value.Item(1).Value <= objArgs.Value.Item(2).Value) -' Set mEqualLess = objRes -' End Function +Function MIsEmpty(objArgs) + CheckArgNum objArgs, 1 + CheckListOrVec objArgs.Item(1) -' Function mGreater(objArgs) -' CheckArgNum objArgs, 2 -' Dim objRes,i -' Set objRes = New MalType -' objRes.Type = TYPE_BOOLEAN -' objRes.Value = (objArgs.Value.Item(1).Value > objArgs.Value.Item(2).Value) -' Set mGreater = objRes -' End Function + Set MIsEmpty = NewMalBool(objArgs.Item(1).Count = 0) +End Function +objNS.Add NewMalSym("empty?"), NewVbsProc("MIsEmpty", False) +Function MCount(objArgs) + CheckArgNum objArgs, 1 + CheckListOrVec objArgs.Item(1) -' Function mLess(objArgs) -' CheckArgNum objArgs, 2 -' Dim objRes,i -' Set objRes = New MalType -' objRes.Type = TYPE_BOOLEAN -' objRes.Value = (objArgs.Value.Item(1).Value < objArgs.Value.Item(2).Value) -' Set mLess = objRes -' End Function + Set MCount = NewMalNum(objArgs.Item(1).Count) +End Function +objNS.Add NewMalSym("count"), NewVbsProc("MCount", False) +Function MEqual(objArgs) + Dim varRet + CheckArgNum objArgs, 2 -' Function mEqual(objArgs) -' CheckArgNum objArgs, 2 -' Dim objRes,i -' Set objRes = New MalType -' objRes.Type = TYPE_BOOLEAN -' objRes.Value = (objArgs.Value.Item(1).Type = objArgs.Value.Item(2).Type) Or _ -' ((objArgs.Value.Item(1).Type = TYPE_LIST Or objArgs.Value.Item(1).Type = TYPE_VECTOR) And _ -' (objArgs.Value.Item(2).Type = TYPE_LIST Or objArgs.Value.Item(2).Type = TYPE_VECTOR)) -' If objRes.Value Then -' 'MsgBox objArgs.Value.Item(1).Type -' If objArgs.Value.Item(1).Type = TYPE_LIST Or objArgs.Value.Item(1).Type = TYPE_VECTOR Then -' objRes.Value = _ -' (objArgs.Value.Item(1).Value.Count = objArgs.Value.Item(2).Value.Count) -' If objRes.Value Then -' Dim objTemp -' For i = 0 To objArgs.Value.Item(1).Value.Count - 1 -' 'an ugly recursion - -' 'MsgBox objArgs.Value.Item(1).Value.Item(i).type -' Set objTemp = New MalType -' objTemp.Type = TYPE_LIST -' Set objTemp.Value = CreateObject("System.Collections.Arraylist") -' objTemp.Value.Add Null -' objTemp.Value.Add objArgs.Value.Item(1).Value.Item(i) -' objTemp.Value.Add objArgs.Value.Item(2).Value.Item(i) - -' objRes.Value = objRes.Value And mEqual(objTemp).Value -' Next -' End If -' Else -' 'MsgBox objArgs.Value.Item(1).Value -' 'MsgBox objArgs.Value.Item(2).Value -' objRes.Value = _ -' (objArgs.Value.Item(1).Value = objArgs.Value.Item(2).Value) -' End If -' End If -' Set mEqual = objRes -' End Function + 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)))).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~" + Case Else + Set varRet = NewMalBool( _ + objArgs.Item(1).Value = objArgs.Item(2).Value) + End Select + End If + End If -' Sub Er(sInfo) -' boolError = True -' strError = sInfo -' End Sub + Set MEqual = varRet +End Function +objNS.Add NewMalSym("="), NewVbsProc("MEqual", False) -' Function mListCount(objArgs) -' CheckArgNum objArgs, 1 -' Dim objRes,i -' Set objRes = New MalType -' objRes.Type = TYPE_NUMBER -' If objArgs.Value.Item(1).Type = TYPE_LIST Then -' objRes.Value = objArgs.Value.Item(1).Value.Count -' ElseIf objArgs.Value.Item(1).Type = TYPE_NIL Then -' objRes.Value = 0 -' Else -' Er "can't count" -' End If -' Set mListCount = objRes -' End Function - -' Function mIsListEmpty(objArgs) -' CheckArgNum objArgs, 1 -' Dim objRes,i -' Set objRes = New MalType -' objRes.Type = TYPE_BOOLEAN -' objRes.Value = (objArgs.Value.Item(1).Value.Count = 0) -' Set mIsListEmpty = objRes -' End Function - -' Function mIsList(objArgs) -' CheckArgNum objArgs, 1 -' Dim objRes,i -' Set objRes = New MalType -' objRes.Type = TYPE_BOOLEAN -' objRes.Value = (objArgs.Value.Item(1).Type = TYPE_LIST) -' Set mIsList = objRes -' End Function - -' Function mMakeList(objArgs) -' Dim objRes,i -' Set objRes = New MalType -' objRes.Type = TYPE_LIST -' Set objRes.Value = CreateObject("System.Collections.ArrayList") -' For i = 1 To objArgs.Value.Count - 1 -' objRes.Value.Add objArgs.Value.Item(i) -' Next -' Set mMakeList = objRes -' End Function - -' Function Add(objArgs) -' CheckArgNum objArgs, 2 -' Set Add = New MalType -' Add.Type = TYPE_NUMBER -' Add.Value = objArgs.Value.Item(1).Value + objArgs.Value.Item(2).Value -' End Function - -' Function Subtract(objArgs) -' CheckArgNum objArgs, 2 -' Set Subtract = New MalType -' Subtract.Type = TYPE_NUMBER -' Subtract.Value = objArgs.Value.Item(1).Value - objArgs.Value.Item(2).Value -' End Function - -' Function Multiply(objArgs) -' CheckArgNum objArgs, 2 -' Set Multiply = New MalType -' Multiply.Type = TYPE_NUMBER -' Multiply.Value = objArgs.Value.Item(1).Value * objArgs.Value.Item(2).Value -' End Function - -' Function Divide(objArgs) -' CheckArgNum objArgs, 2 -' Set Divide = New MalType -' Divide.Type = TYPE_NUMBER -' Divide.Value = objArgs.Value.Item(1).Value \ objArgs.Value.Item(2).Value -' End Function +'Todo > < >= <= pr-str str prn println \ No newline at end of file diff --git a/impls/vbs/env.vbs b/impls/vbs/env.vbs index 94e34857..b350a131 100644 --- a/impls/vbs/env.vbs +++ b/impls/vbs/env.vbs @@ -24,41 +24,7 @@ Class Environment Public Property Set Self(objEnv) Set objSelf = objEnv End Property - - ' Public objBindings - ' Public Sub Init(objBinds, objExpressions) - ' Dim boolVarLen - ' boolVarLen = False - - ' Dim i - ' For i = 0 To objBinds.Value.Count - 1 - ' If objBinds.Value.Item(i).Value = "&" Then flag=True - ' If flag Then - ' 'assume i+1 = objBinds.Value.Count - 1 - ' Dim oTmp - ' Set oTmp = New MalType - ' oTmp.Type = TYPE_LIST - ' Set oTmp.Value = CreateObject("System.Collections.ArrayList") - ' Dim j - ' For j = i+1 To objExpressions.Value.Count - 1 - ' oTmp.Value.Add Evaluate(objExpressions.Value.Item(j), objSelf) - ' Next - ' 'MsgBox objBinds.Value.Item(i+1) - ' Add objBinds.Value.Item(i+1).Value, oTmp - ' Exit For - ' Else - ' Add objBinds.Value.Item(i).Value, _ - ' Evaluate(objExpressions.Value.Item(i+1), objSelf) - ' End If - ' 'wsh.echo objBinds.Value.Item(i).Value - ' 'wsh.echo objExpressions.Value.Item(i).type - ' 'wsh.echo TypeName(Evaluate(objExpressions.Value.Item(i), objSelf)) - ' 'wsh.echo Evaluate(objExpressions.Value.Item(i), objSelf).type - ' Next - ' 'MsgBox objBindings("a") - ' End Sub - Public Sub Add(varKey, varValue) Set objBinds.Item(varKey.Value) = varValue End Sub diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs index fad64cb2..5b3551fb 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -4,59 +4,10 @@ Include "Types.vbs" Include "Reader.vbs" Include "Printer.vbs" Include "Env.vbs" +Include "Core.vbs" Dim objEnv -Set objEnv = NewEnv(Nothing) - -Function MAdd(objArgs) - 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) - 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) - 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) - 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 +Set objEnv = objNS Function MDef(objArgs, objEnv) Dim varRet @@ -74,11 +25,7 @@ Function MLet(objArgs, objEnv) 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 + CheckListOrVec objBinds If objBinds.Count Mod 2 <> 0 Then Err.Raise vbObjectError, _ @@ -135,13 +82,9 @@ Function MFn(objArgs, objEnv) Dim objParams, objCode Set objParams = objArgs.Item(1) + CheckListOrVec objParams Set objCode = objArgs.Item(2) - If objParams.Type <> TYPES.LIST And _ - objParams.Type <> TYPES.VECTOR Then - Err.Raise vbObjectError, _ - "MFn", "Wrong argument type." - End If - + Dim i For i = 0 To objParams.Count - 1 CheckType objParams.Item(i), TYPES.SYMBOL @@ -250,355 +193,4 @@ Sub Include(strFileName) .GetFile(WScript.ScriptFullName)) & _ "\" & strFileName).ReadAll End With -End Sub - - - - - - - - - -' Dim objRootEnv -' Set objRootEnv = New Environment -' objRootEnv.SetSelf objRootEnv -' objRootEnv.SetOuter Nothing -' Dim arrKeys, i -' arrKeys = objCoreNS.Keys -' For i = 0 To UBound(arrKeys) -' objRootEnv.Add arrKeys(i), NewLambda(objCoreNS.Item(arrKeys(i))) -' Next -' objRootEnv.Add "def!", NewSpecialForm("def!") -' objRootEnv.Add "let*", NewSpecialForm("let*") -' objRootEnv.Add "do", NewSpecialForm("do") -' objRootEnv.Add "if", NewSpecialForm("if") -' objRootEnv.Add "fn*", NewSpecialForm("fn*") -' REP "(def! not (fn* (a) (if a false true)))" - -' Function NewLambda(objFunction) -' Dim objMal -' Set objMal = New MalType -' Set objMal.Value = New BuiltInFunction -' Set objMal.Value.Run = objFunction -' objMal.Type = TYPE_LAMBDA -' Set NewLambda = objMal -' End Function - -' Function NewSpecialForm(strValue) -' Set NewSpecialForm = New MalType -' NewSpecialForm.Value = strValue -' NewSpecialForm.Type = TYPE_SPECIAL -' End Function - -' Function IsSpecialForm(objForm) -' IsSpecialForm = (objForm.Type = TYPE_SPECIAL) -' End Function - -' Class SpecialForm -' Public Value -' End Class - -' Sub CheckArgNum(objArgs, lngExpect) -' If objArgs.Value.Count - 1 <> lngExpect Then -' boolError = True -' strError = "wrong number of arguments" -' Call REPL() -' End If -' End Sub - -' Call REPL() -' Sub REPL() -' Dim strCode, strResult -' While True -' If boolError Then -' WScript.StdErr.WriteLine "ERROR: " & strError -' boolError = False -' End If -' 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 -' End Sub - -' Function Read(strCode) -' Set Read = ReadString(strCode) -' End Function - - -' Function Evaluate(objCode, objEnv) -' DEPTH = DEPTH + 1 -' Dim i -' If TypeName(objCode) = "Nothing" Then -' Call REPL() -' End If - -' If objCode.Type = TYPE_LIST Then -' If objCode.Value.Count = 0 Then -' Set Evaluate = objCode -' Exit Function -' End If - -' Dim objSymbol -' 'wsh.echo space(DEPTH*4)&"CHECK FIRST" -' Set objSymbol = Evaluate(objCode.Value.Item(0), objEnv) -' 'wsh.echo space(DEPTH*4)&"CHECK FIRST FINISH" -' 'MsgBox objSymbol.type -' If IsSpecialForm(objSymbol) Then -' 'wsh.echo space(DEPTH*4)&"EVAL SPECIAL" -' 'MsgBox TypeName(objCode.value) -' Select Case objSymbol.Value -' Case "def!" -' 'MsgBox "����def" -' CheckArgNum objCode, 2 -' CheckSymbol objCode.Value.Item(1) -' objEnv.Add objCode.Value.Item(1).Value, _ -' Evaluate(objCode.Value.Item(2), objEnv) -' Set Evaluate = objEnv.Get(objCode.Value.Item(1).Value) -' Case "let*" -' Dim objNewEnv -' Set objNewEnv = New Environment -' objNewEnv.SetSelf objNewEnv -' objNewEnv.SetOuter objEnv -' CheckArgNum objCode, 2 -' CheckListOrVector objCode.Value.Item(1) -' CheckEven objCode.Value.Item(1).Value.Count -' With objCode.Value.Item(1).Value -' For i = 0 To .Count - 1 Step 2 -' CheckSymbol .Item(i) -' objNewEnv.Add .Item(i).Value, _ -' Evaluate(.Item(i + 1), objNewEnv) -' Next -' End With -' Set Evaluate = Evaluate(objCode.Value.Item(2), objNewEnv) -' Case "do" -' Set Evaluate = EvaluateAST(objCode, objEnv) -' Set Evaluate = Evaluate.Value.Item(Evaluate.Value.Count - 1) -' Case "if" -' Dim objCondition -' 'MsgBox 1 -' Set objCondition = Evaluate(objCode.Value.Item(1), objEnv) -' 'MsgBox 2 -' 'MsgBox IsNil(objCondition) -' 'MsgBox IsFalse(objCondition) -' If IsNil(objCondition) Or IsFalse(objCondition) Then -' 'MsgBox 1 -' Select Case objCode.Value.Count - 1 -' Case 2 -' Set Evaluate = New MalType -' Evaluate.Type = TYPE_NIL -' Case 3 -' Set Evaluate = Evaluate(objCode.Value.Item(3), objEnv) -' Case Else -' 'TODO Err -' End Select -' Else -' If objCode.Value.Count - 1 = 2 Or objCode.Value.Count - 1 = 3 Then -' Set Evaluate = Evaluate(objCode.Value.Item(2), objEnv) -' Else -' 'TODO err -' End If -' End If -' Case "fn*" 'lambda -' CheckArgNum objCode, 2 -' Set Evaluate = New MalType -' Evaluate.Type = TYPE_LAMBDA -' Set Evaluate.Value = New Lambda -' 'MsgBox 1 -' Set Evaluate.Value.objEnv = New Environment -' Evaluate.Value.objEnv.SetSelf Evaluate.Value.objEnv -' Evaluate.Value.objEnv.SetOuter objEnv -' Set Evaluate.Value.objParameters = objCode.Value.Item(1) -' Set Evaluate.Value.objBody = objCode.Value.Item(2) -' 'MsgBox 1 -' End Select -' 'wsh.echo space(DEPTH*4)&"EVAL SPECIAL FINISH" -' Else -' 'wsh.echo space(DEPTH*4)&"EVAL NORMAL" -' 'MsgBox 2 -' 'objSymbol.Value.SetEnv objEnv -' 'wsh.echo space(DEPTH*4)&"objcode","type",objCode.Type -' 'If objCode.Type = 7 Then wsh.echo space(DEPTH*4)&objCode.value -' 'If objCode.Type = 8 Then wsh.echo space(DEPTH*4)&objCode.value -' 'If objCode.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(objCode,True) - -' '��������� -' If objSymbol.Value.IsBuiltIn Then -' dim oldenv -' set oldenv = objSymbol.Value.objEnv -' Set objSymbol.Value.objEnv = objEnv -' objSymbol.Value.objEnv.SetSelf objSymbol.Value.objEnv -' objSymbol.Value.objEnv.SetOuter oldEnv -' Set Evaluate = objSymbol.Value.Run(objCode) - -' Else -' Set Evaluate = objSymbol.Value.Run(EvaluateAST(objCode, objEnv)) -' End If -' 'wsh.echo space(DEPTH*4)&"evaluate","type",Evaluate.Type -' 'If Evaluate.Type = 7 Then wsh.echo space(DEPTH*4)&Evaluate.value -' 'If Evaluate.Type = 8 Then wsh.echo space(DEPTH*4)&Evaluate.value -' 'If Evaluate.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(Evaluate,True) -' 'Set Evaluate = Evaluate(objCode, objEnv) -' 'MsgBox Evaluate.type -' 'MsgBox objEnv.Get("N").value -' 'MsgBox 3 -' 'wsh.echo space(DEPTH*4)&"EVAL NORMAL FINISH" -' End If -' Else -' 'wsh.echo space(DEPTH*4)&"objcode","type",objCode.Type -' 'If objCode.Type = 7 Then wsh.echo space(DEPTH*4)&objCode.value -' 'If objCode.Type = 8 Then wsh.echo space(DEPTH*4)&objCode.value -' 'If objCode.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(objCode,True) -' Set Evaluate = EvaluateAST(objCode, objEnv) -' 'wsh.echo space(DEPTH*4)&"evaluate","type",Evaluate.Type -' 'If Evaluate.Type = 7 Then wsh.echo space(DEPTH*4)&Evaluate.value -' 'If Evaluate.Type = 8 Then wsh.echo space(DEPTH*4)&Evaluate.value -' 'If Evaluate.Type = 0 Then wsh.echo space(DEPTH*4)&PrintMalType(Evaluate,True) -' 'wsh.echo "" -' End If -' 'wsh.echo space(DEPTH*4)&"RETURN" -' DEPTH = DEPTH - 1 -' End Function - -' Class BuiltInFunction -' Public IsBuiltIn -' Public Sub Class_Initialize -' IsBuiltIn = False -' End Sub -' Public Run -' Public Sub SetEnv(z) -' End Sub -' End Class - -' Class Lambda -' Public objParameters -' Public objBody -' Public objEnv -' Public IsBuiltIn -' Public Sub Class_Initialize -' IsBuiltIn = True -' End Sub -' Public Function SetEnv(oInv) -' Set objEnv=oInv -' End Function - -' Public Function Run(objArgs) -' Dim objNewEnv -' Set objNewEnv = New Environment -' objNewEnv.SetSelf objNewEnv -' objNewEnv.SetOuter objEnv -' 'MsgBox objArgs.type -' objNewEnv.Init objParameters, objArgs -' 'para start from 0, args start from 1 -' 'MsgBox objNewEnv.Get("N").value -' 'wsh.echo space(DEPTH*4)&"RUN "& PrintMalType(objBody,True) -' Set Run = Evaluate(objBody, objNewEnv) -' 'wsh.echo space(DEPTH*4)&"RUN FINISH" -' 'MsgBox Run.type -' 'MsgBox Run.value -' End Function -' End Class - -' Function IsZero(objMal) -' IsZero = (objMal.Type = TYPE_NUMBER And objMal.Value = 0) -' 'MsgBox IsZero -' End Function - -' Function IsFalse(objMal) -' IsFalse = (objMal.Type = TYPE_BOOLEAN) -' If Not IsFalse Then Exit Function -' IsFalse = IsFalse And (objMal.Value = False) -' End Function - -' Function IsNil(objMal) -' IsNil = (objMal.Type = TYPE_NIL) -' End Function - -' Sub CheckEven(lngNum) -' If lngNum Mod 2 <> 0 Then -' boolError = True -' strError = "not a even number" -' Call REPL() -' End If -' End Sub - -' Sub CheckList(objMal) -' If objMal.Type <> TYPE_LIST Then -' boolError = True -' strError = "neither a list nor a vector" -' Call REPL() -' End If -' End Sub - -' Sub CheckListOrVector(objMal) -' If objMal.Type <> TYPE_LIST And objMal.Type <> TYPE_VECTOR Then -' boolError = True -' strError = "not a list" -' Call REPL() -' End If -' End Sub - -' Sub CheckSymbol(objMal) -' If objMal.Type <> TYPE_SYMBOL Then -' boolError = True -' strError = "not a symbol" -' Call REPL() -' End If -' End Sub - -' Function EvaluateAST(objCode, objEnv) -' If TypeName(objCode) = "Nothing" Then -' MsgBox "Nothing2" -' End If - -' Dim objResult, i -' Select Case objCode.Type -' Case TYPE_SYMBOL -' Set objResult = objEnv.Get(objCode.Value) -' Case TYPE_LIST -' Set objResult = New MalType -' Set objResult.Value = CreateObject("System.Collections.ArrayList") -' objResult.Type = TYPE_LIST -' For i = 0 To objCode.Value.Count - 1 -' objResult.Value.Add Evaluate(objCode.Value.Item(i), objEnv) -' Next -' Case TYPE_VECTOR -' Set objResult = New MalType -' Set objResult.Value = CreateObject("System.Collections.ArrayList") -' objResult.Type = TYPE_VECTOR -' For i = 0 To objCode.Value.Count - 1 -' objResult.Value.Add Evaluate(objCode.Value.Item(i), objEnv) -' Next -' Case TYPE_HASHMAP -' Set objResult = New MalType -' Set objResult.Value = CreateObject("Scripting.Dictionary") -' objResult.Type = TYPE_HASHMAP -' Dim key -' For Each key In objCode.Value.Keys -' objResult.Value.Add Evaluate(key, objEnv), Evaluate(objCode.Value.Item(key), objEnv) -' Next -' Case Else -' Set objResult = objCode -' End Select -' Set EvaluateAST = objResult -' End Function - -' Function Print(objCode) -' Print = PrintMalType(objCode, True) -' End Function - -' Function REP(strCode) -' REP = Print(Evaluate(Read(strCode), objRootEnv)) -' End Function - -' Sub Include(strFileName) -' With CreateObject("Scripting.FileSystemObject") -' ExecuteGlobal .OpenTextFile( _ -' .GetParentFolderName( _ -' .GetFile(WScript.ScriptFullName)) & _ -' "\" & strFileName).ReadAll -' End With -' End Sub +End Sub \ No newline at end of file diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index 53b87c9b..ef8727e9 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -281,6 +281,7 @@ Class MalProcedure 'Extends MalType i = i + 1 End If Wend + Set varRet = Evaluate(objCode, objNewEnv) Set Apply = varRet End Function From 66e294924de6994cfd00b3309986ce687a648f5d Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Fri, 20 Jan 2023 19:15:11 +0800 Subject: [PATCH 26/44] fix evaluater's bug (create instead modify a list) --- impls/vbs/core.vbs | 101 +++++++++++++++++++++++++- impls/vbs/step2_eval.vbs | 21 +++--- impls/vbs/step3_env.vbs | 23 +++--- impls/vbs/step4_if_fn_do.vbs | 113 ++++------------------------- impls/vbs/tests/step4_if_fn_do.mal | 6 ++ impls/vbs/types.vbs | 2 +- 6 files changed, 143 insertions(+), 123 deletions(-) create mode 100644 impls/vbs/tests/step4_if_fn_do.mal diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index cf9e92ce..810a5bdf 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -31,6 +31,91 @@ End Sub Dim objNS Set objNS = NewEnv(Nothing) +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 + 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 + + If Evaluate(objArgs.Item(1), objEnv).Value 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) + Function MAdd(objArgs) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER @@ -139,4 +224,18 @@ Function MEqual(objArgs) End Function objNS.Add NewMalSym("="), NewVbsProc("MEqual", False) -'Todo > < >= <= pr-str str prn println \ No newline at end of file +Function MGreater(objArgs) + 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) + +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))))" \ No newline at end of file diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs index 7dace04f..82120013 100644 --- a/impls/vbs/step2_eval.vbs +++ b/impls/vbs/step2_eval.vbs @@ -112,19 +112,19 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function -Function Evaluate(objCode, objEnv) ' Return Nothing / objCode +Function Evaluate(objCode, objEnv) If TypeName(objCode) = "Nothing" Then Set Evaluate = Nothing Exit Function End If - Dim varRet + Dim varRet, objFirst If objCode.Type = TYPES.LIST Then If objCode.Count = 0 Then ' () Set Evaluate = objCode Exit Function End If - Set objCode.Item(0) = Evaluate(objCode.Item(0), objEnv) - Set varRet = objCode.Item(0).Apply(objCode, objEnv) + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) Else Set varRet = EvaluateAST(objCode, objEnv) End If @@ -142,15 +142,16 @@ Function EvaluateAST(objCode, objEnv) Err.Raise vbObjectError, _ "EvaluateAST", "Unexpect type." Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) For i = 0 To objCode.Count() - 1 - Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) + varRet.Add Evaluate(objCode.Item(i), objEnv) Next - Set varRet = objCode Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) For Each i In objCode.Keys() - Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) + varRet.Add i, Evaluate(objCode.Item(i), objEnv) Next - Set varRet = objCode + 'Case Atom Case Else Set varRet = objCode End Select @@ -161,10 +162,10 @@ 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 - Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) + varRet.Add Evaluate(objCode.Item(i), objEnv) Next - Set varRet = objCode Case Else Err.Raise vbObjectError, _ "EvaluateRest", "Unexpected type." diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs index 8e7f0dc7..fd27a94d 100644 --- a/impls/vbs/step3_env.vbs +++ b/impls/vbs/step3_env.vbs @@ -110,7 +110,7 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 - 'On Error Resume Next + On Error Resume Next WScript.Echo REP(strCode) If Err.Number <> 0 Then WScript.StdErr.WriteLine Err.Source + ": " + Err.Description @@ -123,19 +123,19 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function -Function Evaluate(objCode, objEnv) ' Return Nothing / objCode +Function Evaluate(objCode, objEnv) If TypeName(objCode) = "Nothing" Then Set Evaluate = Nothing Exit Function End If - Dim varRet + Dim varRet, objFirst If objCode.Type = TYPES.LIST Then If objCode.Count = 0 Then ' () Set Evaluate = objCode Exit Function End If - Set objCode.Item(0) = Evaluate(objCode.Item(0), objEnv) - Set varRet = objCode.Item(0).Apply(objCode, objEnv) + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) Else Set varRet = EvaluateAST(objCode, objEnv) End If @@ -153,15 +153,16 @@ Function EvaluateAST(objCode, objEnv) Err.Raise vbObjectError, _ "EvaluateAST", "Unexpect type." Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) For i = 0 To objCode.Count() - 1 - Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) + varRet.Add Evaluate(objCode.Item(i), objEnv) Next - Set varRet = objCode Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) For Each i In objCode.Keys() - Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) + varRet.Add i, Evaluate(objCode.Item(i), objEnv) Next - Set varRet = objCode + 'Case Atom Case Else Set varRet = objCode End Select @@ -172,10 +173,10 @@ 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 - Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) + varRet.Add Evaluate(objCode.Item(i), objEnv) Next - Set varRet = objCode Case Else Err.Raise vbObjectError, _ "EvaluateRest", "Unexpected type." diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs index 5b3551fb..d28a1f70 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -6,94 +6,6 @@ Include "Printer.vbs" Include "Env.vbs" Include "Core.vbs" -Dim objEnv -Set objEnv = objNS - -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) - 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 -objEnv.Add NewMalSym("let*"), NewVbsProc("MLet", True) - -Function MDo(objArgs, objEnv) - Dim varRet, i - For i = 1 To objArgs.Count - 1 - Set varRet = Evaluate(objArgs.Item(i), objEnv) - Next - Set MDo = varRet -End Function -objEnv.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 - - If Evaluate(objArgs.Item(1), objEnv).Value 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 -objEnv.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 -objEnv.Add NewMalSym("fn*"), NewVbsProc("MFn", True) - Call REPL() Sub REPL() Dim strCode, strResult @@ -105,7 +17,7 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 - 'On Error Resume Next + On Error Resume Next WScript.Echo REP(strCode) If Err.Number <> 0 Then WScript.StdErr.WriteLine Err.Source + ": " + Err.Description @@ -118,19 +30,19 @@ Function Read(strCode) Set Read = ReadString(strCode) End Function -Function Evaluate(objCode, objEnv) ' Return Nothing / objCode +Function Evaluate(objCode, objEnv) If TypeName(objCode) = "Nothing" Then Set Evaluate = Nothing Exit Function End If - Dim varRet + Dim varRet, objFirst If objCode.Type = TYPES.LIST Then If objCode.Count = 0 Then ' () Set Evaluate = objCode Exit Function End If - Set objCode.Item(0) = Evaluate(objCode.Item(0), objEnv) - Set varRet = objCode.Item(0).Apply(objCode, objEnv) + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) Else Set varRet = EvaluateAST(objCode, objEnv) End If @@ -148,15 +60,16 @@ Function EvaluateAST(objCode, objEnv) Err.Raise vbObjectError, _ "EvaluateAST", "Unexpect type." Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) For i = 0 To objCode.Count() - 1 - Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) + varRet.Add Evaluate(objCode.Item(i), objEnv) Next - Set varRet = objCode Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) For Each i In objCode.Keys() - Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) + varRet.Add i, Evaluate(objCode.Item(i), objEnv) Next - Set varRet = objCode + 'Case Atom Case Else Set varRet = objCode End Select @@ -167,10 +80,10 @@ 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 - Set objCode.Item(i) = Evaluate(objCode.Item(i), objEnv) + varRet.Add Evaluate(objCode.Item(i), objEnv) Next - Set varRet = objCode Case Else Err.Raise vbObjectError, _ "EvaluateRest", "Unexpected type." @@ -183,7 +96,7 @@ Function Print(objCode) End Function Function REP(strCode) - REP = Print(Evaluate(Read(strCode), objEnv)) + REP = Print(Evaluate(Read(strCode), objNS)) End Function Sub Include(strFileName) diff --git a/impls/vbs/tests/step4_if_fn_do.mal b/impls/vbs/tests/step4_if_fn_do.mal new file mode 100644 index 00000000..b5a0ea3c --- /dev/null +++ b/impls/vbs/tests/step4_if_fn_do.mal @@ -0,0 +1,6 @@ +(def! f (fn* [x] (list x))) +(f 0) +(f 1) + +((fn* [x] x) (list)) +((fn* [x] [x]) (list)) \ No newline at end of file diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index ef8727e9..c08a87b4 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -282,7 +282,7 @@ Class MalProcedure 'Extends MalType End If Wend - Set varRet = Evaluate(objCode, objNewEnv) + Set varRet = Evaluate(objCode, objNewEnv) 'todo: make a objcode copy Set Apply = varRet End Function End Class From 6edf59821462d896d8e90ae89e5e5ad85e66622e Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Fri, 20 Jan 2023 21:36:46 +0800 Subject: [PATCH 27/44] add prn println str prn-str --- impls/vbs/core.vbs | 81 ++++++++++++++++++++++++++++++++++++++++++--- impls/vbs/types.vbs | 2 +- 2 files changed, 77 insertions(+), 6 deletions(-) diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index 810a5bdf..54ee74d9 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -85,7 +85,16 @@ Function MIf(objArgs, objEnv) "MIf", "Wrong number of arguments." End If - If Evaluate(objArgs.Item(1), objEnv).Value Then + 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 @@ -180,9 +189,12 @@ objNS.Add NewMalSym("empty?"), NewVbsProc("MIsEmpty", False) Function MCount(objArgs) CheckArgNum objArgs, 1 - CheckListOrVec objArgs.Item(1) - - Set MCount = NewMalNum(objArgs.Item(1).Count) + 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) @@ -238,4 +250,63 @@ objNS.Add NewMalSym(">"), NewVbsProc("MGreater", False) 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))))" \ No newline at end of file +REP "(def! >= (fn* [a b] (not (> b a))))" + +Function MPrStr(objArgs) + 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) + 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) + Dim varRet + Dim objStr + Set objStr = MPrStr(objArgs) + WScript.StdOut.WriteLine objStr.Value + Set varRet = NewMalNil() + Set MPrn = varRet +End Function +objNS.Add NewMalSym("prn"), NewVbsProc("MPrn", False) + +Function MPrintln(objArgs) + 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) diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index c08a87b4..2b4d039b 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -47,7 +47,7 @@ Function NewMalBool(varValue) End Function Function NewMalNil() - Set NewMalNil = NewMalType(TYPES.NIL, Null) + Set NewMalNil = NewMalType(TYPES.NIL, Empty) End Function Function NewMalKwd(varValue) From 383f14fd5392bb1d7e88a84435d91ee337261c01 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Fri, 20 Jan 2023 21:50:12 +0800 Subject: [PATCH 28/44] move specials from core to step4 --- impls/vbs/core.vbs | 106 +++-------------------------------- impls/vbs/step4_if_fn_do.vbs | 100 +++++++++++++++++++++++++++++++++ 2 files changed, 107 insertions(+), 99 deletions(-) diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index 54ee74d9..91835201 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -31,100 +31,6 @@ End Sub Dim objNS Set objNS = NewEnv(Nothing) -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 - 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) - Function MAdd(objArgs) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER @@ -247,11 +153,6 @@ Function MGreater(objArgs) End Function objNS.Add NewMalSym(">"), NewVbsProc("MGreater", False) -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))))" - Function MPrStr(objArgs) Dim varRet Dim strRet @@ -310,3 +211,10 @@ Function MPrintln(objArgs) 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))))" +End Sub \ No newline at end of file diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs index d28a1f70..e9cb6dd2 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -6,6 +6,106 @@ Include "Printer.vbs" Include "Env.vbs" Include "Core.vbs" +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 From b48411fba0db4ff1833a9abbacb3c48abd4f3872 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sat, 21 Jan 2023 00:09:26 +0800 Subject: [PATCH 29/44] fix ByRef's bug, todo: fix mem leak --- impls/vbs/env.vbs | 4 + impls/vbs/step4_if_fn_do.vbs | 7 + impls/vbs/step5_tco.vbs | 236 +++++++++++++++++++++++++++++ impls/vbs/tests/step4_if_fn_do.mal | 6 - impls/vbs/types.vbs | 3 +- 5 files changed, 248 insertions(+), 8 deletions(-) create mode 100644 impls/vbs/step5_tco.vbs delete mode 100644 impls/vbs/tests/step4_if_fn_do.mal diff --git a/impls/vbs/env.vbs b/impls/vbs/env.vbs index b350a131..8bddd939 100644 --- a/impls/vbs/env.vbs +++ b/impls/vbs/env.vbs @@ -21,6 +21,10 @@ Class Environment Set objOuter = objEnv End Property + Public Property Get Outer() + Set Outer = objOuter + End Property + Public Property Set Self(objEnv) Set objSelf = objEnv End Property diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs index e9cb6dd2..30b832a4 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -6,6 +6,13 @@ 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 diff --git a/impls/vbs/step5_tco.vbs b/impls/vbs/step5_tco.vbs new file mode 100644 index 00000000..25208a13 --- /dev/null +++ b/impls/vbs/step5_tco.vbs @@ -0,0 +1,236 @@ +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 + + On Error Resume Next + WScript.Echo REP(strCode) + If Err.Number <> 0 Then + WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + 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 Atom + 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 \ No newline at end of file diff --git a/impls/vbs/tests/step4_if_fn_do.mal b/impls/vbs/tests/step4_if_fn_do.mal deleted file mode 100644 index b5a0ea3c..00000000 --- a/impls/vbs/tests/step4_if_fn_do.mal +++ /dev/null @@ -1,6 +0,0 @@ -(def! f (fn* [x] (list x))) -(f 0) -(f 1) - -((fn* [x] x) (list)) -((fn* [x] [x]) (list)) \ No newline at end of file diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index 2b4d039b..6b24264d 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -251,7 +251,6 @@ Class MalProcedure 'Extends MalType Public Function Apply(objArgs, objEnv) Dim varRet - Dim objNewEnv Set objNewEnv = NewEnv(objSavedEnv) Dim i @@ -282,7 +281,7 @@ Class MalProcedure 'Extends MalType End If Wend - Set varRet = Evaluate(objCode, objNewEnv) 'todo: make a objcode copy + Set varRet = EvalLater(objCode, objNewEnv) Set Apply = varRet End Function End Class From 6ccf1cb9b3a45bae00ce8a3e0b4a9c1bf2a32ae0 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sun, 22 Jan 2023 22:41:56 +0800 Subject: [PATCH 30/44] step6 finish! --- impls/vbs/core.vbs | 99 ++++++++++++++- impls/vbs/printer.vbs | 4 +- impls/vbs/step5_tco.vbs | 1 + impls/vbs/step6_file.vbs | 264 +++++++++++++++++++++++++++++++++++++++ impls/vbs/types.vbs | 27 +++- 5 files changed, 388 insertions(+), 7 deletions(-) create mode 100644 impls/vbs/step6_file.vbs diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index 91835201..da136722 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -217,4 +217,101 @@ Sub InitBuiltIn() REP "(def! <= (fn* [a b] (not (> a b))))" REP "(def! < (fn* [a b] (> b a)))" REP "(def! >= (fn* [a b] (not (> b a))))" -End Sub \ No newline at end of file + REP "(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))" +End Sub + +Function MReadStr(objArgs) + Dim varRes + CheckArgNum objArgs, 1 + CheckType objArgs.Item(1), TYPES.STRING + + Set varRes = ReadString(objArgs.Item(1).Value) + Set MReadStr = varRes +End Function +objNS.Add NewMalSym("read-string"), NewVbsProc("MReadStr", False) + +Function MSlurp(objArgs) + 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) + 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) + 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) + 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) + 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 + Set objAtom = Evaluate(objArgs.Item(1), objEnv) + CheckType objAtom, TYPES.ATOM + + Dim objFn + Set objFn = Evaluate(objArgs.Item(2), objEnv) + CheckType objFn, TYPES.PROCEDURE + + Dim objProc + Set objProc = NewMalList(Array(objFn)) + objProc.Add objAtom.Value + Dim i + For i = 3 To objArgs.Count - 1 + objProc.Add Evaluate(objArgs.Item(i), objEnv) + Next + + objAtom.Reset Evaluate(objProc, objEnv) + Set varRes = objAtom.Value + Set MSwap = varRes +End Function +objNS.Add NewMalSym("swap!"), NewVbsProc("MSwap", True) diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs index a01fa97c..fd78defe 100644 --- a/impls/vbs/printer.vbs +++ b/impls/vbs/printer.vbs @@ -74,9 +74,11 @@ Function PrintMalType(objMal, boolReadable) 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" + "PrintMalType", "Unknown type." End Select PrintMalType = varResult diff --git a/impls/vbs/step5_tco.vbs b/impls/vbs/step5_tco.vbs index 25208a13..50001f5b 100644 --- a/impls/vbs/step5_tco.vbs +++ b/impls/vbs/step5_tco.vbs @@ -152,6 +152,7 @@ Function Evaluate(ByVal objCode, ByVal objEnv) Set Evaluate = Nothing Exit Function End If + Dim varRet, objFirst If objCode.Type = TYPES.LIST Then If objCode.Count = 0 Then ' () diff --git a/impls/vbs/step6_file.vbs b/impls/vbs/step6_file.vbs new file mode 100644 index 00000000..95c3356e --- /dev/null +++ b/impls/vbs/step6_file.vbs @@ -0,0 +1,264 @@ +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) + """)" + wsh.echo 1111 + 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 + + On Error Resume Next + WScript.Echo REP(strCode) + If Err.Number <> 0 Then + WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + 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 \ No newline at end of file diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index 6b24264d..4bd8198d 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -6,14 +6,14 @@ Set TYPES = New MalTypes Class MalTypes Public LIST, VECTOR, HASHMAP, [BOOLEAN], NIL Public KEYWORD, [STRING], NUMBER, SYMBOL - Public PROCEDURE + Public PROCEDURE, ATOM Public [TypeName] Private Sub Class_Initialize [TypeName] = Array( _ "LIST", "VECTOR", "HASHMAP", "BOOLEAN", _ "NIL", "KEYWORD", "STRING", "NUMBER", _ - "SYMBOL", "PROCEDURE") + "SYMBOL", "PROCEDURE", "ATOM") Dim i For i = 0 To UBound([TypeName]) @@ -30,9 +30,6 @@ Class MalType [Type] = lngType Value = varValue End Function - - Public Function Copy() - End Function End Class Function NewMalType(lngType, varValue) @@ -66,6 +63,26 @@ Function NewMalSym(varValue) Set NewMalSym = NewMalType(TYPES.SYMBOL, varValue) End Function +Class MalAtom + Public [Type] + Public Value + + 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 From 12ed8863e99f90267db73ef3c078d0759b527879 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sun, 22 Jan 2023 22:59:42 +0800 Subject: [PATCH 31/44] rewrite all: normal fun will recive Env also --- impls/vbs/core.vbs | 62 +++++++++++++++++++--------------------- impls/vbs/step2_eval.vbs | 24 ++++++++-------- impls/vbs/step3_env.vbs | 8 +++--- impls/vbs/step6_file.vbs | 1 - impls/vbs/types.vbs | 2 +- 5 files changed, 47 insertions(+), 50 deletions(-) diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index da136722..98a133ce 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -31,7 +31,7 @@ End Sub Dim objNS Set objNS = NewEnv(Nothing) -Function MAdd(objArgs) +Function MAdd(objArgs, objEnv) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER CheckType objArgs.Item(2), TYPES.NUMBER @@ -40,7 +40,7 @@ Function MAdd(objArgs) End Function objNS.Add NewMalSym("+"), NewVbsProc("MAdd", False) -Function MSub(objArgs) +Function MSub(objArgs, objEnv) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER CheckType objArgs.Item(2), TYPES.NUMBER @@ -49,7 +49,7 @@ Function MSub(objArgs) End Function objNS.Add NewMalSym("-"), NewVbsProc("MSub", False) -Function MMul(objArgs) +Function MMul(objArgs, objEnv) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER CheckType objArgs.Item(2), TYPES.NUMBER @@ -58,7 +58,7 @@ Function MMul(objArgs) End Function objNS.Add NewMalSym("*"), NewVbsProc("MMul", False) -Function MDiv(objArgs) +Function MDiv(objArgs, objEnv) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER CheckType objArgs.Item(2), TYPES.NUMBER @@ -67,7 +67,7 @@ Function MDiv(objArgs) End Function objNS.Add NewMalSym("/"), NewVbsProc("MDiv", False) -Function MList(objArgs) +Function MList(objArgs, objEnv) Dim varRet Set varRet = NewMalList(Array()) Dim i @@ -78,14 +78,14 @@ Function MList(objArgs) End Function objNS.Add NewMalSym("list"), NewVbsProc("MList", False) -Function MIsList(objArgs) +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) +Function MIsEmpty(objArgs, objEnv) CheckArgNum objArgs, 1 CheckListOrVec objArgs.Item(1) @@ -93,7 +93,7 @@ Function MIsEmpty(objArgs) End Function objNS.Add NewMalSym("empty?"), NewVbsProc("MIsEmpty", False) -Function MCount(objArgs) +Function MCount(objArgs, objEnv) CheckArgNum objArgs, 1 If objArgs.Item(1).Type = TYPES.NIL Then Set MCount = NewMalNum(0) @@ -104,7 +104,7 @@ Function MCount(objArgs) End Function objNS.Add NewMalSym("count"), NewVbsProc("MCount", False) -Function MEqual(objArgs) +Function MEqual(objArgs, objEnv) Dim varRet CheckArgNum objArgs, 2 @@ -142,7 +142,7 @@ Function MEqual(objArgs) End Function objNS.Add NewMalSym("="), NewVbsProc("MEqual", False) -Function MGreater(objArgs) +Function MGreater(objArgs, objEnv) Dim varRet CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER @@ -153,7 +153,7 @@ Function MGreater(objArgs) End Function objNS.Add NewMalSym(">"), NewVbsProc("MGreater", False) -Function MPrStr(objArgs) +Function MPrStr(objArgs, objEnv) Dim varRet Dim strRet strRet = "" @@ -170,7 +170,7 @@ Function MPrStr(objArgs) End Function objNS.Add NewMalSym("pr-str"), NewVbsProc("MPrStr", False) -Function MStr(objArgs) +Function MStr(objArgs, objEnv) Dim varRet Dim strRet strRet = "" @@ -184,17 +184,17 @@ Function MStr(objArgs) End Function objNS.Add NewMalSym("str"), NewVbsProc("MStr", False) -Function MPrn(objArgs) +Function MPrn(objArgs, objEnv) Dim varRet Dim objStr - Set objStr = MPrStr(objArgs) + 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) +Function MPrintln(objArgs, objEnv) Dim varRet Dim strRes strRes = "" @@ -220,7 +220,7 @@ Sub InitBuiltIn() REP "(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))" End Sub -Function MReadStr(objArgs) +Function MReadStr(objArgs, objEnv) Dim varRes CheckArgNum objArgs, 1 CheckType objArgs.Item(1), TYPES.STRING @@ -230,7 +230,7 @@ Function MReadStr(objArgs) End Function objNS.Add NewMalSym("read-string"), NewVbsProc("MReadStr", False) -Function MSlurp(objArgs) +Function MSlurp(objArgs, objEnv) Dim varRes CheckArgNum objArgs, 1 CheckType objArgs.Item(1), TYPES.STRING @@ -248,7 +248,7 @@ Function MSlurp(objArgs) End Function objNS.Add NewMalSym("slurp"), NewVbsProc("MSlurp", False) -Function MAtom(objArgs) +Function MAtom(objArgs, objEnv) Dim varRes CheckArgNum objArgs, 1 @@ -257,7 +257,7 @@ Function MAtom(objArgs) End Function objNS.Add NewMalSym("atom"), NewVbsProc("MAtom", False) -Function MIsAtom(objArgs) +Function MIsAtom(objArgs, objEnv) Dim varRes CheckArgNum objArgs, 1 @@ -266,7 +266,7 @@ Function MIsAtom(objArgs) End Function objNS.Add NewMalSym("atom?"), NewVbsProc("MIsAtom", False) -Function MDeref(objArgs) +Function MDeref(objArgs, objEnv) Dim varRes CheckArgNum objArgs, 1 CheckType objArgs.Item(1), TYPES.ATOM @@ -276,7 +276,7 @@ Function MDeref(objArgs) End Function objNS.Add NewMalSym("deref"), NewVbsProc("MDeref", False) -Function MReset(objArgs) +Function MReset(objArgs, objEnv) Dim varRes CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.ATOM @@ -294,24 +294,22 @@ Function MSwap(objArgs, objEnv) "MSwap", "Need more arguments." End If - Dim objAtom - Set objAtom = Evaluate(objArgs.Item(1), objEnv) + Dim objAtom, objFn + Set objAtom = objArgs.Item(1) CheckType objAtom, TYPES.ATOM - - Dim objFn - Set objFn = Evaluate(objArgs.Item(2), objEnv) + Set objFn = objArgs.Item(2) CheckType objFn, TYPES.PROCEDURE - Dim objProc - Set objProc = NewMalList(Array(objFn)) - objProc.Add objAtom.Value + Dim objProg + Set objProg = NewMalList(Array(objFn)) + objProg.Add objAtom.Value Dim i For i = 3 To objArgs.Count - 1 - objProc.Add Evaluate(objArgs.Item(i), objEnv) + objProg.Add objArgs.Item(i) Next - objAtom.Reset Evaluate(objProc, objEnv) + objAtom.Reset Evaluate(objProg, objEnv) Set varRes = objAtom.Value Set MSwap = varRes End Function -objNS.Add NewMalSym("swap!"), NewVbsProc("MSwap", True) +objNS.Add NewMalSym("swap!"), NewVbsProc("MSwap", False) diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs index 82120013..3506b8ee 100644 --- a/impls/vbs/step2_eval.vbs +++ b/impls/vbs/step2_eval.vbs @@ -38,41 +38,41 @@ Dim objEnv Set objEnv = New Enviroment Set objEnv.Self = objEnv -Function Add(objArgs) +Function MAdd(objArgs, objEnv) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER CheckType objArgs.Item(2), TYPES.NUMBER - Set Add = NewMalNum( _ + Set MAdd = NewMalNum( _ objArgs.Item(1).Value + objArgs.Item(2).Value) End Function -objEnv.Add NewMalSym("+"), NewVbsProc("Add", False) +objEnv.Add NewMalSym("+"), NewVbsProc("MAdd", False) -Function [Sub](objArgs) +Function MSub(objArgs, objEnv) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER CheckType objArgs.Item(2), TYPES.NUMBER - Set [Sub] = NewMalNum( _ + Set MSub = NewMalNum( _ objArgs.Item(1).Value - objArgs.Item(2).Value) End Function -objEnv.Add NewMalSym("-"), NewVbsProc("Sub", False) +objEnv.Add NewMalSym("-"), NewVbsProc("MSub", False) -Function Mul(objArgs) +Function MMul(objArgs, objEnv) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER CheckType objArgs.Item(2), TYPES.NUMBER - Set Mul = NewMalNum( _ + Set MMul = NewMalNum( _ objArgs.Item(1).Value * objArgs.Item(2).Value) End Function -objEnv.Add NewMalSym("*"), NewVbsProc("Mul", False) +objEnv.Add NewMalSym("*"), NewVbsProc("MMul", False) -Function Div(objArgs) +Function MDiv(objArgs, objEnv) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER CheckType objArgs.Item(2), TYPES.NUMBER - Set Div = NewMalNum( _ + Set MDiv = NewMalNum( _ objArgs.Item(1).Value \ objArgs.Item(2).Value) End Function -objEnv.Add NewMalSym("/"), NewVbsProc("Div", False) +objEnv.Add NewMalSym("/"), NewVbsProc("MDiv", False) Sub CheckArgNum(objArgs, lngArgNum) If objArgs.Count - 1 <> lngArgNum Then diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs index fd27a94d..294046d6 100644 --- a/impls/vbs/step3_env.vbs +++ b/impls/vbs/step3_env.vbs @@ -8,7 +8,7 @@ Include "Env.vbs" Dim objEnv Set objEnv = NewEnv(Nothing) -Function MAdd(objArgs) +Function MAdd(objArgs, objEnv) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER CheckType objArgs.Item(2), TYPES.NUMBER @@ -17,7 +17,7 @@ Function MAdd(objArgs) End Function objEnv.Add NewMalSym("+"), NewVbsProc("MAdd", False) -Function MSub(objArgs) +Function MSub(objArgs, objEnv) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER CheckType objArgs.Item(2), TYPES.NUMBER @@ -26,7 +26,7 @@ Function MSub(objArgs) End Function objEnv.Add NewMalSym("-"), NewVbsProc("MSub", False) -Function MMul(objArgs) +Function MMul(objArgs, objEnv) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER CheckType objArgs.Item(2), TYPES.NUMBER @@ -35,7 +35,7 @@ Function MMul(objArgs) End Function objEnv.Add NewMalSym("*"), NewVbsProc("MMul", False) -Function MDiv(objArgs) +Function MDiv(objArgs, objEnv) CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.NUMBER CheckType objArgs.Item(2), TYPES.NUMBER diff --git a/impls/vbs/step6_file.vbs b/impls/vbs/step6_file.vbs index 95c3356e..2fb698ad 100644 --- a/impls/vbs/step6_file.vbs +++ b/impls/vbs/step6_file.vbs @@ -146,7 +146,6 @@ Sub InitArgs() If WScript.Arguments.Count > 0 Then REP "(load-file """ + WScript.Arguments.Item(0) + """)" - wsh.echo 1111 End If End Sub diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index 4bd8198d..1b010027 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -238,7 +238,7 @@ Class VbsProcedure 'Extends MalType If boolSpec Then Set varResult = Value(objArgs, objEnv) Else - Set varResult = Value(EvaluateRest(objArgs, objEnv)) + Set varResult = Value(EvaluateRest(objArgs, objEnv), objEnv) End If Set Apply = varResult End Function From d1535b08355c06bc7e1e733ec52caaad7785d2f9 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Tue, 24 Jan 2023 00:32:39 +0800 Subject: [PATCH 32/44] step 7 finish a half --- impls/vbs/core.vbs | 32 ++++ impls/vbs/install.vbs | 3 +- impls/vbs/step0_repl.vbs | 2 +- impls/vbs/step1_read_print.vbs | 2 +- impls/vbs/step2_eval.vbs | 3 +- impls/vbs/step3_env.vbs | 3 +- impls/vbs/step4_if_fn_do.vbs | 3 +- impls/vbs/step5_tco.vbs | 3 +- impls/vbs/step6_file.vbs | 2 +- impls/vbs/step7_quote.vbs | 328 +++++++++++++++++++++++++++++++++ 10 files changed, 368 insertions(+), 13 deletions(-) create mode 100644 impls/vbs/step7_quote.vbs diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index 98a133ce..41123713 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -218,6 +218,7 @@ Sub InitBuiltIn() 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)))" End Sub Function MReadStr(objArgs, objEnv) @@ -313,3 +314,34 @@ Function MSwap(objArgs, objEnv) 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) diff --git a/impls/vbs/install.vbs b/impls/vbs/install.vbs index a66409b0..ca97f529 100644 --- a/impls/vbs/install.vbs +++ b/impls/vbs/install.vbs @@ -1,3 +1,2 @@ On Error Resume Next -With CreateObject("System.Collections.ArrayList") -End With \ No newline at end of file +CreateObject("System.Collections.ArrayList") \ No newline at end of file diff --git a/impls/vbs/step0_repl.vbs b/impls/vbs/step0_repl.vbs index c965e395..9c920dab 100644 --- a/impls/vbs/step0_repl.vbs +++ b/impls/vbs/step0_repl.vbs @@ -18,7 +18,7 @@ End Function Dim strCode While True 'REPL - WScript.StdOut.Write("user> ") + WScript.StdOut.Write "user> " On Error Resume Next strCode = WScript.StdIn.ReadLine() If Err.Number <> 0 Then WScript.Quit 0 diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs index 31475478..ececf82d 100644 --- a/impls/vbs/step1_read_print.vbs +++ b/impls/vbs/step1_read_print.vbs @@ -9,7 +9,7 @@ Call REPL() Sub REPL() Dim strCode While True - WScript.StdOut.Write("user> ") + WScript.StdOut.Write "user> " On Error Resume Next strCode = WScript.StdIn.ReadLine() diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs index 3506b8ee..b132000f 100644 --- a/impls/vbs/step2_eval.vbs +++ b/impls/vbs/step2_eval.vbs @@ -92,7 +92,7 @@ Call REPL() Sub REPL() Dim strCode, strResult While True - WScript.StdOut.Write("user> ") + WScript.StdOut.Write "user> " On Error Resume Next strCode = WScript.StdIn.ReadLine() @@ -151,7 +151,6 @@ Function EvaluateAST(objCode, objEnv) For Each i In objCode.Keys() varRet.Add i, Evaluate(objCode.Item(i), objEnv) Next - 'Case Atom Case Else Set varRet = objCode End Select diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs index 294046d6..bd6d4558 100644 --- a/impls/vbs/step3_env.vbs +++ b/impls/vbs/step3_env.vbs @@ -103,7 +103,7 @@ Call REPL() Sub REPL() Dim strCode, strResult While True - WScript.StdOut.Write("user> ") + WScript.StdOut.Write "user> " On Error Resume Next strCode = WScript.StdIn.ReadLine() @@ -162,7 +162,6 @@ Function EvaluateAST(objCode, objEnv) For Each i In objCode.Keys() varRet.Add i, Evaluate(objCode.Item(i), objEnv) Next - 'Case Atom Case Else Set varRet = objCode End Select diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs index 30b832a4..83e37741 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -117,7 +117,7 @@ Call REPL() Sub REPL() Dim strCode, strResult While True - WScript.StdOut.Write("user> ") + WScript.StdOut.Write "user> " On Error Resume Next strCode = WScript.StdIn.ReadLine() @@ -176,7 +176,6 @@ Function EvaluateAST(objCode, objEnv) For Each i In objCode.Keys() varRet.Add i, Evaluate(objCode.Item(i), objEnv) Next - 'Case Atom Case Else Set varRet = objCode End Select diff --git a/impls/vbs/step5_tco.vbs b/impls/vbs/step5_tco.vbs index 50001f5b..5462aa3d 100644 --- a/impls/vbs/step5_tco.vbs +++ b/impls/vbs/step5_tco.vbs @@ -126,7 +126,7 @@ Call REPL() Sub REPL() Dim strCode, strResult While True - WScript.StdOut.Write("user> ") + WScript.StdOut.Write "user> " On Error Resume Next strCode = WScript.StdIn.ReadLine() @@ -197,7 +197,6 @@ Function EvaluateAST(objCode, objEnv) For Each i In objCode.Keys() varRet.Add i, Evaluate(objCode.Item(i), objEnv) Next - 'Case Atom Case Else Set varRet = objCode End Select diff --git a/impls/vbs/step6_file.vbs b/impls/vbs/step6_file.vbs index 2fb698ad..4c0e7955 100644 --- a/impls/vbs/step6_file.vbs +++ b/impls/vbs/step6_file.vbs @@ -153,7 +153,7 @@ Call REPL() Sub REPL() Dim strCode, strResult While True - WScript.StdOut.Write("user> ") + WScript.StdOut.Write "user> " On Error Resume Next strCode = WScript.StdIn.ReadLine() diff --git a/impls/vbs/step7_quote.vbs b/impls/vbs/step7_quote.vbs new file mode 100644 index 00000000..bc001a16 --- /dev/null +++ b/impls/vbs/step7_quote.vbs @@ -0,0 +1,328 @@ +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 = QuasiQuoteHelper(objArgs.Item(1), objEnv).Item(0) + Set MQuasiQuote = varRes +End Function +objNS.Add NewMalSym("quasiquote"), NewVbsProc("MQuasiQuote", True) + +Function QuasiQuoteHelper(objArg, objEnv) + Dim varRes + If IsListOrVec(objArg) Then + Dim i, j + Dim objList + If objArg.Count > 0 Then + If objArg.Item(0).Type = TYPES.SYMBOL Then + Select Case objArg.Item(0).Value + Case "unquote" ' ~x -> (x) + CheckArgNum objArg, 1 + Set varRes = NewMalList(Array( _ + Evaluate(objArg.Item(1), objEnv))) + Case "splice-unquote" ' ~@x -> x + CheckArgNum objArg, 1 + Set varRes = Evaluate(objArg.Item(1), objEnv) + If Not IsListOrVec(varRes) Then + Err.Raise vbObjectError, _ + "QuasiQuoteHelper", "Wrong return value type." + End If + Case Else ' (x y z) -> ((x y z)) + Set varRes = NewMalList(Array()) + varRes.Add NewMalList(Array()) + For i = 0 To objArg.Count - 1 + Set objList = QuasiQuoteHelper(objArg.Item(i), objEnv) + For j = 0 To objList.Count - 1 + varRes.Item(0).Add objList.Item(j) + Next + Next + End Select + Else ' (x y z) -> ((x y z)) + Set varRes = NewMalList(Array()) + varRes.Add NewMalList(Array()) + For i = 0 To objArg.Count - 1 + Set objList = QuasiQuoteHelper(objArg.Item(i), objEnv) + For j = 0 To objList.Count - 1 + varRes.Item(0).Add objList.Item(j) + Next + Next + End If + Else ' () -> (()) + Set varRes = NewMalList(Array( _ + NewMalList(Array()))) + End If + Else ' x -> (x) + Set varRes = NewMalList(Array(objArg)) + End If + + Set QuasiQuoteHelper = varRes +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) + """)" + 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 + + 'On Error Resume Next + WScript.Echo REP(strCode) + If Err.Number <> 0 Then + WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + 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 \ No newline at end of file From cb4511c9f58a3900b0757503404e65ca37a505d4 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Thu, 26 Jan 2023 17:10:03 +0800 Subject: [PATCH 33/44] rewrite quasiquote with quasiquoteexpand & fix vec --- impls/vbs/step7_quote.vbs | 145 +++++++++++++++++++++++++++----------- 1 file changed, 102 insertions(+), 43 deletions(-) diff --git a/impls/vbs/step7_quote.vbs b/impls/vbs/step7_quote.vbs index bc001a16..5d3ed5b8 100644 --- a/impls/vbs/step7_quote.vbs +++ b/impls/vbs/step7_quote.vbs @@ -140,59 +140,118 @@ Function MQuasiQuote(objArgs, objEnv) Dim varRes CheckArgNum objArgs, 1 - Set varRes = QuasiQuoteHelper(objArgs.Item(1), objEnv).Item(0) + Set varRes = EvalLater( _ + MQuasiQuoteExpand(objArgs, objEnv), objEnv) Set MQuasiQuote = varRes End Function objNS.Add NewMalSym("quasiquote"), NewVbsProc("MQuasiQuote", True) -Function QuasiQuoteHelper(objArg, objEnv) +Function MQuasiQuoteExpand(objArgs, objEnv) Dim varRes - If IsListOrVec(objArg) Then - Dim i, j - Dim objList - If objArg.Count > 0 Then - If objArg.Item(0).Type = TYPES.SYMBOL Then - Select Case objArg.Item(0).Value - Case "unquote" ' ~x -> (x) - CheckArgNum objArg, 1 - Set varRes = NewMalList(Array( _ - Evaluate(objArg.Item(1), objEnv))) - Case "splice-unquote" ' ~@x -> x - CheckArgNum objArg, 1 - Set varRes = Evaluate(objArg.Item(1), objEnv) - If Not IsListOrVec(varRes) Then - Err.Raise vbObjectError, _ - "QuasiQuoteHelper", "Wrong return value type." - End If - Case Else ' (x y z) -> ((x y z)) - Set varRes = NewMalList(Array()) - varRes.Add NewMalList(Array()) - For i = 0 To objArg.Count - 1 - Set objList = QuasiQuoteHelper(objArg.Item(i), objEnv) - For j = 0 To objList.Count - 1 - varRes.Item(0).Add objList.Item(j) - Next - Next - End Select - Else ' (x y z) -> ((x y z)) + 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()) - varRes.Add NewMalList(Array()) + Set varBuilder = varRes + For i = 0 To objArg.Count - 1 - Set objList = QuasiQuoteHelper(objArg.Item(i), objEnv) - For j = 0 To objList.Count - 1 - varRes.Item(0).Add objList.Item(j) - Next + 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 - Else ' () -> (()) + Case TYPES.VECTOR Set varRes = NewMalList(Array( _ - NewMalList(Array()))) - End If - Else ' x -> (x) - Set varRes = NewMalList(Array(objArg)) - End If + 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 QuasiQuoteHelper = varRes + Set ExpandHelper = NewExpandType(varRes, boolSplice) End Function Call InitBuiltIn() @@ -225,7 +284,7 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 - 'On Error Resume Next + On Error Resume Next WScript.Echo REP(strCode) If Err.Number <> 0 Then WScript.StdErr.WriteLine Err.Source + ": " + Err.Description From 994aa6c08155f47a5c67a66b6a11332f79f6f1fe Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Thu, 26 Jan 2023 18:57:47 +0800 Subject: [PATCH 34/44] step8 a half finished --- impls/vbs/step8_macros.vbs | 443 +++++++++++++++++++++++++++++++++++++ impls/vbs/types.vbs | 66 +++++- 2 files changed, 507 insertions(+), 2 deletions(-) create mode 100644 impls/vbs/step8_macros.vbs diff --git a/impls/vbs/step8_macros.vbs b/impls/vbs/step8_macros.vbs new file mode 100644 index 00000000..f24be3a4 --- /dev/null +++ b/impls/vbs/step8_macros.vbs @@ -0,0 +1,443 @@ +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) + 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 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) + """)" + 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 + + 'On Error Resume Next + WScript.Echo REP(strCode) + If Err.Number <> 0 Then + WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + 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 \ No newline at end of file diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index 1b010027..2653afbb 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -223,11 +223,17 @@ Class VbsProcedure 'Extends MalType Public [Type] Public Value + Public IsMacro Public boolSpec Private Sub Class_Initialize [Type] = TYPES.PROCEDURE + IsMacro = False End Sub + Public Property Get IsSpecial() + IsSpecial = boolSpec + End Property + Public Function Init(objFunction, boolIsSpec) Set Value = objFunction boolSpec = boolIsSpec @@ -255,8 +261,15 @@ Class MalProcedure 'Extends MalType Public [Type] Public Value + Public IsMacro + + Public Property Get IsSpecial() + IsSpecial = False + End Property + Private Sub Class_Initialize [Type] = TYPES.PROCEDURE + IsMacro = False End Sub Private objParams, objCode, objSavedEnv @@ -285,12 +298,12 @@ Class MalProcedure 'Extends MalType i = objParams.Count ' Break While Else Err.Raise vbObjectError, _ - "MalProcedure", "Invalid parameter(s)." + "MalProcedureApply", "Invalid parameter(s)." End If Else If i + 1 >= objArgs.Count Then Err.Raise vbObjectError, _ - "MalProcedure", "Need more arguments." + "MalProcedureApply", "Need more arguments." End If objNewEnv.Add objParams.Item(i), _ Evaluate(objArgs.Item(i + 1), objEnv) @@ -301,6 +314,47 @@ Class MalProcedure 'Extends MalType 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()) + 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 + objNewEnv.Add objParams.Item(i), _ + objArgs.Item(i + 1) + i = i + 1 + End If + Wend + + Set varRet = Evaluate(objCode, objNewEnv) + Set MacroApply = varRet + End Function End Class Function NewMalProc(objParams, objCode, objEnv) @@ -308,4 +362,12 @@ Function NewMalProc(objParams, objCode, objEnv) 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 \ No newline at end of file From f5ef7fcc5ab5d0f90b599df0567e346774732bb8 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Thu, 26 Jan 2023 19:49:30 +0800 Subject: [PATCH 35/44] step8 finish! --- impls/vbs/core.vbs | 64 ++++++++++++++++++++++++++++++++++++++ impls/vbs/step8_macros.vbs | 8 ++++- impls/vbs/types.vbs | 5 +++ 3 files changed, 76 insertions(+), 1 deletion(-) diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index 41123713..c8b31d2a 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -345,3 +345,67 @@ Function MVec(objArgs, objEnv) 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 bound." + 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 = NewMalNil() + 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) + diff --git a/impls/vbs/step8_macros.vbs b/impls/vbs/step8_macros.vbs index f24be3a4..c14231c6 100644 --- a/impls/vbs/step8_macros.vbs +++ b/impls/vbs/step8_macros.vbs @@ -308,6 +308,12 @@ End Function objNS.Add NewMalSym("macroexpand"), NewVbsProc("MMacroExpand", True) Call InitBuiltIn() +Call InitMacro() + +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))))))))" +End Sub Call InitArgs() Sub InitArgs() @@ -337,7 +343,7 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 - 'On Error Resume Next + On Error Resume Next WScript.Echo REP(strCode) If Err.Number <> 0 Then WScript.StdErr.WriteLine Err.Source + ": " + Err.Description diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index 2653afbb..e4a04a5a 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -331,6 +331,8 @@ Class MalProcedure 'Extends MalType 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) @@ -346,12 +348,15 @@ Class MalProcedure 'Extends MalType 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 From 558d254639076bda8dbe057da93c87d544732d8d Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Thu, 26 Jan 2023 21:51:50 +0800 Subject: [PATCH 36/44] step9 finished a quarter --- impls/vbs/core.vbs | 36 +++ impls/vbs/step8_macros.vbs | 5 - impls/vbs/step9_try.vbs | 493 +++++++++++++++++++++++++++++++++++++ impls/vbs/types.vbs | 5 + 4 files changed, 534 insertions(+), 5 deletions(-) create mode 100644 impls/vbs/step9_try.vbs diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index c8b31d2a..d9fec768 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -409,3 +409,39 @@ Function MRest(objArgs, objEnv) 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))))))))" +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) \ No newline at end of file diff --git a/impls/vbs/step8_macros.vbs b/impls/vbs/step8_macros.vbs index c14231c6..94e98d0e 100644 --- a/impls/vbs/step8_macros.vbs +++ b/impls/vbs/step8_macros.vbs @@ -310,11 +310,6 @@ objNS.Add NewMalSym("macroexpand"), NewVbsProc("MMacroExpand", True) Call InitBuiltIn() Call InitMacro() -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))))))))" -End Sub - Call InitArgs() Sub InitArgs() Dim objArgs diff --git a/impls/vbs/step9_try.vbs b/impls/vbs/step9_try.vbs new file mode 100644 index 00000000..136f3c96 --- /dev/null +++ b/impls/vbs/step9_try.vbs @@ -0,0 +1,493 @@ +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) + 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 + + 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() + + Set varRes = Evaluate(NewMalList(Array( _ + NewMalSym("let*"), NewMalList(Array( _ + objCatch.Item(1), objException)), _ + objCatch.Item(2))), objEnv) + End If + On Error Goto 0 + + 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) + """)" + 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 + + On Error Resume Next + WScript.Echo REP(strCode) + If Err.Number <> 0 Then + If Err.Source = "MThrow" Then + WScript.StdErr.WriteLine Err.Source + ": " + _ + PrintMalType(objExceptions.Item(Err.Description), True) + objExceptions.Remove Err.Description + Else + WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + End If + End If + On Error Goto 0 + Wend +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(ByVal objCode, ByVal objEnv) + While True + If TypeName(objCode) = "Nothing" Then + Set Evaluate = Nothing + Exit Function + End If + + Set objCode = MacroExpand(objCode, objEnv) + + Dim varRet, objFirst + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () + Set Evaluate = objCode + Exit Function + End If + + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) + Else + Set varRet = EvaluateAST(objCode, objEnv) + End If + + If TypeName(varRet) = "TailCall" Then + ' NOTICE: If not specify 'ByVal', + ' Change of arguments will influence + ' the caller's variable! + Set objCode = varRet.objMalType + Set objEnv = varRet.objEnv + Else + Set Evaluate = varRet + Exit Function + End If + Wend +End Function + + +Function EvaluateAST(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) + For i = 0 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) + For Each i In objCode.Keys() + varRet.Add i, Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Set varRet = objCode + End Select + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + Set varRet = NewMalList(Array(NewMalNil())) + For i = 1 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet +End Function + +Function Print(objCode) + Print = PrintMalType(objCode, True) +End Function + +Function REP(strCode) + REP = Print(Evaluate(Read(strCode), objNS)) +End Function + +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With +End Sub \ No newline at end of file diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index e4a04a5a..b0cc09bc 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -280,6 +280,11 @@ Class MalProcedure 'Extends MalType 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) From 9c9beecb549b9aa90584d60e621500818f148dc7 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Fri, 27 Jan 2023 13:45:58 +0800 Subject: [PATCH 37/44] step9 finish except hashmap --- impls/vbs/core.vbs | 132 +++++++++++++++++++++++++++++++++++++++- impls/vbs/step9_try.vbs | 11 ++++ impls/vbs/types.vbs | 51 +++++++++++++++- 3 files changed, 192 insertions(+), 2 deletions(-) diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index d9fec768..c80ad1c8 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -219,6 +219,10 @@ Sub InitBuiltIn() 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)))" End Sub Function MReadStr(objArgs, objEnv) @@ -444,4 +448,130 @@ Function MThrow(objArgs, objEnv) Err.Raise vbObjectError, _ "MThrow", strRnd End Function -objNS.Add NewMalSym("throw"), NewVbsProc("MThrow", False) \ No newline at end of file +objNS.Add NewMalSym("throw"), NewVbsProc("MThrow", True) + +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) \ No newline at end of file diff --git a/impls/vbs/step9_try.vbs b/impls/vbs/step9_try.vbs index 136f3c96..5c4c7d43 100644 --- a/impls/vbs/step9_try.vbs +++ b/impls/vbs/step9_try.vbs @@ -309,6 +309,17 @@ 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 diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index b0cc09bc..71f07c8b 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -248,6 +248,13 @@ Class VbsProcedure 'Extends MalType End If Set Apply = varResult End Function + + Public Function ApplyWithoutEval(objArgs, objEnv) + Dim varResult + Set varResult = Value(objArgs, objEnv) + + Set ApplyWithoutEval = varResult + End Function End Class Function NewVbsProc(strFnName, boolSpec) @@ -363,7 +370,49 @@ Class MalProcedure 'Extends MalType ' EvalLater -> Evaluate Set varRet = Evaluate(objCode, objNewEnv) - Set MacroApply = varRet + Set ApplyWithoutEval = 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 End Class From a1c1584fdd820114e76ac6dae9fd8c090634bbcb Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sat, 28 Jan 2023 01:11:37 +0800 Subject: [PATCH 38/44] step9 pass! --- impls/vbs/core.vbs | 134 ++++++++++++++++++++++++++++++++++++++-- impls/vbs/step9_try.vbs | 2 +- impls/vbs/types.vbs | 71 ++++++++++++++++++--- 3 files changed, 194 insertions(+), 13 deletions(-) diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index c80ad1c8..32ae52e1 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -119,7 +119,7 @@ Function MEqual(objArgs, objEnv) boolResult = boolResult And _ MEqual(NewMalList(Array(Nothing, _ objArgs.Item(1).Item(i), _ - objArgs.Item(2).Item(i)))).Value + objArgs.Item(2).Item(i))), objEnv).Value Next Set varRet = NewMalBool(boolResult) End If @@ -129,8 +129,27 @@ Function MEqual(objArgs, objEnv) Else Select Case objArgs.Item(1).Type Case TYPES.HASHMAP - Err.Raise vbObjectError, _ - "MEqual", "Not implement yet~" + '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) @@ -223,6 +242,7 @@ Sub InitBuiltIn() 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))))" End Sub Function MReadStr(objArgs, objEnv) @@ -574,4 +594,110 @@ Function MIsMap(objArgs, objEnv) Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.HASHMAP) Set MIsMap = varRes End Function -objNS.Add NewMalSym("map?"), NewVbsProc("MIsMap", False) \ No newline at end of file +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 MVals +' objNS.Add NewMalSym("vals"), NewVbsProc("MVals", 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) \ No newline at end of file diff --git a/impls/vbs/step9_try.vbs b/impls/vbs/step9_try.vbs index 5c4c7d43..b30ca0e4 100644 --- a/impls/vbs/step9_try.vbs +++ b/impls/vbs/step9_try.vbs @@ -392,7 +392,7 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 - On Error Resume Next + 'On Error Resume Next WScript.Echo REP(strCode) If Err.Number <> 0 Then If Err.Source = "MThrow" Then diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index 71f07c8b..092a1a5f 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -183,16 +183,60 @@ Class MalHashmap 'Extends MalType Public Function Init(arrKeys, arrValues) Dim i For i = 0 To UBound(arrKeys) - .Add arrKeys(i), arrValues(i) + 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) - Value.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() - Keys = Value.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() @@ -200,15 +244,26 @@ Class MalHashmap 'Extends MalType End Function Public Property Get Item(i) - Set Item = Value.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(i) = varValue + wsh.echo 2 + Value.Item(M2S(i)) = varValue End Property Public Property Set Item(i, varValue) - Set Value.Item(i) = varValue + wsh.echo 1 + Set Value.Item(M2S(i)) = varValue End Property End Class @@ -370,7 +425,7 @@ Class MalProcedure 'Extends MalType ' EvalLater -> Evaluate Set varRet = Evaluate(objCode, objNewEnv) - Set ApplyWithoutEval = varRet + Set MacroApply = varRet End Function From d04ba87317591b406f9928d1a2ee4a0c5e7fba2e Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sat, 28 Jan 2023 13:51:46 +0800 Subject: [PATCH 39/44] STEPA FINISH!!! --- impls/vbs/core.vbs | 174 ++++++++++++- impls/vbs/step8_macros.vbs | 2 +- impls/vbs/step9_try.vbs | 4 +- impls/vbs/stepA_mal.vbs | 505 +++++++++++++++++++++++++++++++++++++ impls/vbs/types.vbs | 131 +++++++++- 5 files changed, 803 insertions(+), 13 deletions(-) create mode 100644 impls/vbs/stepA_mal.vbs diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index 32ae52e1..71a79b12 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -243,6 +243,7 @@ Sub InitBuiltIn() 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* ""Visual Basic Script"")" End Sub Function MReadStr(objArgs, objEnv) @@ -333,7 +334,7 @@ Function MSwap(objArgs, objEnv) objProg.Add objArgs.Item(i) Next - objAtom.Reset Evaluate(objProg, objEnv) + objAtom.Reset objFn.ApplyWithoutEval(objProg, objEnv) Set varRes = objAtom.Value Set MSwap = varRes End Function @@ -435,7 +436,10 @@ 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 "(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 @@ -630,7 +634,6 @@ Function MAssoc(objArgs, objEnv) 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) @@ -691,13 +694,170 @@ Function MKeys(objArgs, objEnv) End Function objNS.Add NewMalSym("keys"), NewVbsProc("MKeys", False) -' Function MVals -' objNS.Add NewMalSym("vals"), NewVbsProc("MVals", 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) \ No newline at end of file +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) + diff --git a/impls/vbs/step8_macros.vbs b/impls/vbs/step8_macros.vbs index 94e98d0e..5a71f23b 100644 --- a/impls/vbs/step8_macros.vbs +++ b/impls/vbs/step8_macros.vbs @@ -258,7 +258,7 @@ Function MDefMacro(objArgs, objEnv) Dim varRet CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.SYMBOL - Set varRet = Evaluate(objArgs.Item(2), objEnv) + Set varRet = Evaluate(objArgs.Item(2), objEnv).Copy() CheckType varRet, TYPES.PROCEDURE varRet.IsMacro = True objEnv.Add objArgs.Item(1), varRet diff --git a/impls/vbs/step9_try.vbs b/impls/vbs/step9_try.vbs index b30ca0e4..77d50427 100644 --- a/impls/vbs/step9_try.vbs +++ b/impls/vbs/step9_try.vbs @@ -258,7 +258,7 @@ Function MDefMacro(objArgs, objEnv) Dim varRet CheckArgNum objArgs, 2 CheckType objArgs.Item(1), TYPES.SYMBOL - Set varRet = Evaluate(objArgs.Item(2), objEnv) + Set varRet = Evaluate(objArgs.Item(2), objEnv).Copy() CheckType varRet, TYPES.PROCEDURE varRet.IsMacro = True objEnv.Add objArgs.Item(1), varRet @@ -392,7 +392,7 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 - 'On Error Resume Next + On Error Resume Next WScript.Echo REP(strCode) If Err.Number <> 0 Then If Err.Source = "MThrow" Then diff --git a/impls/vbs/stepA_mal.vbs b/impls/vbs/stepA_mal.vbs new file mode 100644 index 00000000..637123e7 --- /dev/null +++ b/impls/vbs/stepA_mal.vbs @@ -0,0 +1,505 @@ +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() + + Set varRes = Evaluate(NewMalList(Array( _ + NewMalSym("let*"), NewMalList(Array( _ + objCatch.Item(1), objException)), _ + objCatch.Item(2))), objEnv) + End If + On Error Goto 0 + + 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) + """)" + 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 + + On Error Resume Next + WScript.Echo REP(strCode) + If Err.Number <> 0 Then + If Err.Source = "MThrow" Then + WScript.StdErr.WriteLine Err.Source + ": " + _ + PrintMalType(objExceptions.Item(Err.Description), True) + objExceptions.Remove Err.Description + Else + WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + End If + End If + On Error Goto 0 + Wend +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(ByVal objCode, ByVal objEnv) + While True + If TypeName(objCode) = "Nothing" Then + Set Evaluate = Nothing + Exit Function + End If + + Set objCode = MacroExpand(objCode, objEnv) + + Dim varRet, objFirst + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () + Set Evaluate = objCode + Exit Function + End If + + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) + Else + Set varRet = EvaluateAST(objCode, objEnv) + End If + + If TypeName(varRet) = "TailCall" Then + ' NOTICE: If not specify 'ByVal', + ' Change of arguments will influence + ' the caller's variable! + Set objCode = varRet.objMalType + Set objEnv = varRet.objEnv + Else + Set Evaluate = varRet + Exit Function + End If + Wend +End Function + + +Function EvaluateAST(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) + For i = 0 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) + For Each i In objCode.Keys() + varRet.Add i, Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Set varRet = objCode + End Select + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + Set varRet = NewMalList(Array(NewMalNil())) + For i = 1 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet +End Function + +Function Print(objCode) + Print = PrintMalType(objCode, True) +End Function + +Function REP(strCode) + REP = Print(Evaluate(Read(strCode), objNS)) +End Function + +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With +End Sub diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index 092a1a5f..0c08c95e 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -26,6 +26,23 @@ 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 @@ -66,6 +83,23 @@ 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 @@ -87,6 +121,24 @@ 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") @@ -131,6 +183,24 @@ 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") @@ -175,6 +245,25 @@ 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") @@ -257,12 +346,10 @@ Class MalHashmap 'Extends MalType End Function Public Property Let Item(i, varValue) - wsh.echo 2 Value.Item(M2S(i)) = varValue End Property Public Property Set Item(i, varValue) - wsh.echo 1 Set Value.Item(M2S(i)) = varValue End Property End Class @@ -280,9 +367,11 @@ Class VbsProcedure 'Extends MalType Public IsMacro Public boolSpec + Public MetaData Private Sub Class_Initialize [Type] = TYPES.PROCEDURE IsMacro = False + Set MetaData = NewMalNil() End Sub Public Property Get IsSpecial() @@ -310,6 +399,16 @@ Class VbsProcedure 'Extends MalType 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) @@ -329,12 +428,14 @@ Class MalProcedure 'Extends MalType IsSpecial = False End Property + Public MetaData Private Sub Class_Initialize [Type] = TYPES.PROCEDURE IsMacro = False + Set MetaData = NewMalNil() End Sub - Private objParams, objCode, objSavedEnv + Public objParams, objCode, objSavedEnv Public Function Init(objP, objC, objE) Set objParams = objP Set objCode = objC @@ -469,6 +570,19 @@ Class MalProcedure 'Extends MalType 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) @@ -484,4 +598,15 @@ Function NewMalMacro(objParams, objCode, objEnv) 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 \ No newline at end of file From d44cddbe23751380eb514c23869159609ba777dc Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sat, 28 Jan 2023 23:33:10 +0800 Subject: [PATCH 40/44] fix (rest nil) try+catch+throw 's bugs --- impls/vbs/core.vbs | 9 ++++-- impls/vbs/step6_file.vbs | 1 + impls/vbs/step7_quote.vbs | 1 + impls/vbs/step8_macros.vbs | 1 + impls/vbs/step9_try.vbs | 41 ++++++++++++++----------- impls/vbs/stepA_mal.vbs | 49 ++++++++++++++++++------------ impls/vbs/tests/step4_if_fn_do.mal | 6 ++++ impls/vbs/tests/step9_try.mal | 4 +++ 8 files changed, 73 insertions(+), 39 deletions(-) create mode 100644 impls/vbs/tests/step4_if_fn_do.mal create mode 100644 impls/vbs/tests/step9_try.mal diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index 71a79b12..ade71332 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -243,7 +243,7 @@ Sub InitBuiltIn() 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* ""Visual Basic Script"")" + REP "(def! *host-language* ""VBScript"")" End Sub Function MReadStr(objArgs, objEnv) @@ -252,6 +252,9 @@ Function MReadStr(objArgs, objEnv) 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) @@ -415,7 +418,7 @@ Function MRest(objArgs, objEnv) CheckArgNum objArgs, 1 If objArgs.Item(1).Type = TYPES.NIL Then - Set varRes = NewMalNil() + Set varRes = NewMalList(Array()) Set MRest = varRes Exit Function End If @@ -472,7 +475,7 @@ Function MThrow(objArgs, objEnv) Err.Raise vbObjectError, _ "MThrow", strRnd End Function -objNS.Add NewMalSym("throw"), NewVbsProc("MThrow", True) +objNS.Add NewMalSym("throw"), NewVbsProc("MThrow", False) Function MApply(objArgs, objEnv) Dim varRes diff --git a/impls/vbs/step6_file.vbs b/impls/vbs/step6_file.vbs index 4c0e7955..3829e790 100644 --- a/impls/vbs/step6_file.vbs +++ b/impls/vbs/step6_file.vbs @@ -146,6 +146,7 @@ Sub InitArgs() If WScript.Arguments.Count > 0 Then REP "(load-file """ + WScript.Arguments.Item(0) + """)" + WScript.Quit 0 End If End Sub diff --git a/impls/vbs/step7_quote.vbs b/impls/vbs/step7_quote.vbs index 5d3ed5b8..c22120f4 100644 --- a/impls/vbs/step7_quote.vbs +++ b/impls/vbs/step7_quote.vbs @@ -270,6 +270,7 @@ Sub InitArgs() If WScript.Arguments.Count > 0 Then REP "(load-file """ + WScript.Arguments.Item(0) + """)" + WScript.Quit 0 End If End Sub diff --git a/impls/vbs/step8_macros.vbs b/impls/vbs/step8_macros.vbs index 5a71f23b..ad3a4e64 100644 --- a/impls/vbs/step8_macros.vbs +++ b/impls/vbs/step8_macros.vbs @@ -324,6 +324,7 @@ Sub InitArgs() If WScript.Arguments.Count > 0 Then REP "(load-file """ + WScript.Arguments.Item(0) + """)" + WScript.Quit 0 End If End Sub diff --git a/impls/vbs/step9_try.vbs b/impls/vbs/step9_try.vbs index 77d50427..42d0c30c 100644 --- a/impls/vbs/step9_try.vbs +++ b/impls/vbs/step9_try.vbs @@ -337,25 +337,31 @@ Function MTry(objArgs, objEnv) End If On Error Resume Next - Set varRes = Evaluate(objTry, objEnv) - If Err.Number <> 0 Then - Dim objException + 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() - - Set varRes = Evaluate(NewMalList(Array( _ - NewMalSym("let*"), NewMalList(Array( _ - objCatch.Item(1), objException)), _ - objCatch.Item(2))), objEnv) + If Err.Source <> "MThrow" Then + Set objException = NewMalStr(Err.Description) + Else + Set objException = objExceptions.Item(Err.Description) + objExceptions.Remove Err.Description End If - On Error Goto 0 + + 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 @@ -378,6 +384,7 @@ Sub InitArgs() If WScript.Arguments.Count > 0 Then REP "(load-file """ + WScript.Arguments.Item(0) + """)" + WScript.Quit 0 End If End Sub diff --git a/impls/vbs/stepA_mal.vbs b/impls/vbs/stepA_mal.vbs index 637123e7..7a322a1d 100644 --- a/impls/vbs/stepA_mal.vbs +++ b/impls/vbs/stepA_mal.vbs @@ -337,25 +337,31 @@ Function MTry(objArgs, objEnv) End If On Error Resume Next - Set varRes = Evaluate(objTry, objEnv) - If Err.Number <> 0 Then - Dim objException + 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() - - Set varRes = Evaluate(NewMalList(Array( _ - NewMalSym("let*"), NewMalList(Array( _ - objCatch.Item(1), objException)), _ - objCatch.Item(2))), objEnv) + If Err.Source <> "MThrow" Then + Set objException = NewMalStr(Err.Description) + Else + Set objException = objExceptions.Item(Err.Description) + objExceptions.Remove Err.Description End If - On Error Goto 0 + + 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 @@ -378,6 +384,7 @@ Sub InitArgs() If WScript.Arguments.Count > 0 Then REP "(load-file """ + WScript.Arguments.Item(0) + """)" + WScript.Quit 0 End If End Sub @@ -392,9 +399,13 @@ Sub REPL() strCode = WScript.StdIn.ReadLine() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 - + + Dim strRes On Error Resume Next - WScript.Echo REP(strCode) + strRes = REP(strCode) + If strRes <> "" Then + WScript.Echo strRes + End If If Err.Number <> 0 Then If Err.Source = "MThrow" Then WScript.StdErr.WriteLine Err.Source + ": " + _ diff --git a/impls/vbs/tests/step4_if_fn_do.mal b/impls/vbs/tests/step4_if_fn_do.mal new file mode 100644 index 00000000..8697f6be --- /dev/null +++ b/impls/vbs/tests/step4_if_fn_do.mal @@ -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]) \ No newline at end of file diff --git a/impls/vbs/tests/step9_try.mal b/impls/vbs/tests/step9_try.mal new file mode 100644 index 00000000..4217ffb7 --- /dev/null +++ b/impls/vbs/tests/step9_try.mal @@ -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)) From 51cd399d4ed2df72c6a575ee50c983d1676882f7 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sun, 29 Jan 2023 00:13:45 +0800 Subject: [PATCH 41/44] rewrite error strings & remove my debug error info --- impls/vbs/core.vbs | 2 +- impls/vbs/env.vbs | 2 +- impls/vbs/reader.vbs | 22 +++++++++++----------- impls/vbs/step1_read_print.vbs | 9 +++++++-- impls/vbs/step2_eval.vbs | 9 +++++++-- impls/vbs/step3_env.vbs | 9 +++++++-- impls/vbs/step4_if_fn_do.vbs | 9 +++++++-- impls/vbs/step5_tco.vbs | 9 +++++++-- impls/vbs/step6_file.vbs | 9 +++++++-- impls/vbs/step7_quote.vbs | 9 +++++++-- impls/vbs/step8_macros.vbs | 9 +++++++-- impls/vbs/step9_try.vbs | 12 +++++++++--- impls/vbs/stepA_mal.vbs | 6 ++++-- 13 files changed, 82 insertions(+), 34 deletions(-) diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index ade71332..5ec631ca 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -384,7 +384,7 @@ Function MNth(objArgs, objEnv) Set varRes = objArgs.Item(1).Item(objArgs.Item(2).Value) Else Err.Raise vbObjectError, _ - "MNth", "Index out of bound." + "MNth", "Index out of bounds." End If Set MNth = varRes diff --git a/impls/vbs/env.vbs b/impls/vbs/env.vbs index 8bddd939..c86671b4 100644 --- a/impls/vbs/env.vbs +++ b/impls/vbs/env.vbs @@ -42,7 +42,7 @@ Class Environment Set varRet = objOuter.Find(varKey) Else Err.Raise vbObjectError, _ - "Environment", "Symbol '" + varKey.Value + "' not found." + "Environment", "'" + varKey.Value + "' not found" End If End If diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index f258ca0a..7c6c9dfc 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -6,7 +6,7 @@ Function ReadString(strCode) Set ReadString = ReadForm(objTokens) If Not objTokens.AtEnd() Then Err.Raise vbObjectError, _ - "ReadForm", "Extra token '" + objTokens.Current() + "'." + "ReadForm", "extra token '" + objTokens.Current() + "'." End If End Function @@ -91,7 +91,7 @@ Function ReadForm(objTokens) ' Return Nothing / MalType Set varResult = ReadSpecial(objTokens) ElseIf InStr(")]}", strToken) Then Err.Raise vbObjectError, _ - "ReadForm", "Unbalanced parentheses." + "ReadForm", "unbalanced parentheses." ElseIf strToken = "^" Then Set varResult = ReadMetadata(objTokens) Else @@ -132,7 +132,7 @@ Function ReadSpecial(objTokens) strAlias = "deref" Case Else Err.Raise vbObjectError, _ - "ReadSpecial", "Unknown token '" & strAlias & "'." + "ReadSpecial", "unknown token '" & strAlias & "'." End Select Call objTokens.MoveToNext() @@ -149,7 +149,7 @@ Function ReadList(objTokens) If objTokens.AtEnd() Then Err.Raise vbObjectError, _ - "ReadList", "Unbalanced parentheses." + "ReadList", "unbalanced parentheses." End If Set varResult = NewMalList(Array()) @@ -161,7 +161,7 @@ Function ReadList(objTokens) If objTokens.MoveToNext() <> ")" Then Err.Raise vbObjectError, _ - "ReadList", "Unbalanced parentheses." + "ReadList", "unbalanced parentheses." End If Set ReadList = varResult @@ -173,7 +173,7 @@ Function ReadVector(objTokens) If objTokens.AtEnd() Then Err.Raise vbObjectError, _ - "ReadVector", "Unbalanced parentheses." + "ReadVector", "unbalanced parentheses." End If Set varResult = NewMalVec(Array()) @@ -185,7 +185,7 @@ Function ReadVector(objTokens) If objTokens.MoveToNext() <> "]" Then Err.Raise vbObjectError, _ - "ReadVector", "Unbalanced parentheses." + "ReadVector", "unbalanced parentheses." End If Set ReadVector = varResult @@ -197,7 +197,7 @@ Function ReadHashmap(objTokens) If objTokens.Count = 0 Then Err.Raise vbObjectError, _ - "ReadHashmap", "Unbalanced parentheses." + "ReadHashmap", "unbalanced parentheses." End If Set varResult = NewMalMap(Array(), Array()) @@ -212,7 +212,7 @@ Function ReadHashmap(objTokens) If objTokens.MoveToNext() <> "}" Then Err.Raise vbObjectError, _ - "ReadHashmap", "Unbalanced parentheses." + "ReadHashmap", "unbalanced parentheses." End If Set ReadHashmap = varResult @@ -252,7 +252,7 @@ End Function Function ParseString(strRaw) If Right(strRaw, 1) <> """" Or Len(strRaw) < 2 Then Err.Raise vbObjectError, _ - "ParseString", "Unterminated string, got EOF." + "ParseString", "unterminated string, got EOF." End If Dim strTemp @@ -281,7 +281,7 @@ Function ParseString(strRaw) ParseString = ParseString & Right(strTemp, 1) Else Err.Raise vbObjectError, _ - "ParseString", "Unterminated string, got EOF." + "ParseString", "unterminated string, got EOF." End If End If End Function diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs index ececf82d..a54140ec 100644 --- a/impls/vbs/step1_read_print.vbs +++ b/impls/vbs/step1_read_print.vbs @@ -16,10 +16,15 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 + Dim strRes On Error Resume Next - WScript.Echo REP(strCode) + strRes = REP(strCode) + If strRes <> "" Then + WScript.Echo strRes + End If If Err.Number <> 0 Then - WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description End If On Error Goto 0 Wend diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs index b132000f..e6cad481 100644 --- a/impls/vbs/step2_eval.vbs +++ b/impls/vbs/step2_eval.vbs @@ -99,10 +99,15 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 + Dim strRes On Error Resume Next - WScript.Echo REP(strCode) + strRes = REP(strCode) + If strRes <> "" Then + WScript.Echo strRes + End If If Err.Number <> 0 Then - WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description End If On Error Goto 0 Wend diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs index bd6d4558..ddfaf392 100644 --- a/impls/vbs/step3_env.vbs +++ b/impls/vbs/step3_env.vbs @@ -110,10 +110,15 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 + Dim strRes On Error Resume Next - WScript.Echo REP(strCode) + strRes = REP(strCode) + If strRes <> "" Then + WScript.Echo strRes + End If If Err.Number <> 0 Then - WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description End If On Error Goto 0 Wend diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs index 83e37741..fc90594e 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -124,10 +124,15 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 + Dim strRes On Error Resume Next - WScript.Echo REP(strCode) + strRes = REP(strCode) + If strRes <> "" Then + WScript.Echo strRes + End If If Err.Number <> 0 Then - WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description End If On Error Goto 0 Wend diff --git a/impls/vbs/step5_tco.vbs b/impls/vbs/step5_tco.vbs index 5462aa3d..bdba9e96 100644 --- a/impls/vbs/step5_tco.vbs +++ b/impls/vbs/step5_tco.vbs @@ -133,10 +133,15 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 + Dim strRes On Error Resume Next - WScript.Echo REP(strCode) + strRes = REP(strCode) + If strRes <> "" Then + WScript.Echo strRes + End If If Err.Number <> 0 Then - WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description End If On Error Goto 0 Wend diff --git a/impls/vbs/step6_file.vbs b/impls/vbs/step6_file.vbs index 3829e790..1ca114a3 100644 --- a/impls/vbs/step6_file.vbs +++ b/impls/vbs/step6_file.vbs @@ -161,10 +161,15 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 + Dim strRes On Error Resume Next - WScript.Echo REP(strCode) + strRes = REP(strCode) + If strRes <> "" Then + WScript.Echo strRes + End If If Err.Number <> 0 Then - WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description End If On Error Goto 0 Wend diff --git a/impls/vbs/step7_quote.vbs b/impls/vbs/step7_quote.vbs index c22120f4..6d6365c0 100644 --- a/impls/vbs/step7_quote.vbs +++ b/impls/vbs/step7_quote.vbs @@ -285,10 +285,15 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 + Dim strRes On Error Resume Next - WScript.Echo REP(strCode) + strRes = REP(strCode) + If strRes <> "" Then + WScript.Echo strRes + End If If Err.Number <> 0 Then - WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description End If On Error Goto 0 Wend diff --git a/impls/vbs/step8_macros.vbs b/impls/vbs/step8_macros.vbs index ad3a4e64..7b54d2f6 100644 --- a/impls/vbs/step8_macros.vbs +++ b/impls/vbs/step8_macros.vbs @@ -339,10 +339,15 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 + Dim strRes On Error Resume Next - WScript.Echo REP(strCode) + strRes = REP(strCode) + If strRes <> "" Then + WScript.Echo strRes + End If If Err.Number <> 0 Then - WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description End If On Error Goto 0 Wend diff --git a/impls/vbs/step9_try.vbs b/impls/vbs/step9_try.vbs index 42d0c30c..6c309a9f 100644 --- a/impls/vbs/step9_try.vbs +++ b/impls/vbs/step9_try.vbs @@ -399,15 +399,21 @@ Sub REPL() If Err.Number <> 0 Then WScript.Quit 0 On Error Goto 0 + Dim strRes On Error Resume Next - WScript.Echo REP(strCode) + strRes = REP(strCode) + If strRes <> "" Then + WScript.Echo strRes + End If If Err.Number <> 0 Then If Err.Source = "MThrow" Then - WScript.StdErr.WriteLine Err.Source + ": " + _ + 'WScript.StdErr.WriteLine 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 Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description End If End If On Error Goto 0 diff --git a/impls/vbs/stepA_mal.vbs b/impls/vbs/stepA_mal.vbs index 7a322a1d..542f5f26 100644 --- a/impls/vbs/stepA_mal.vbs +++ b/impls/vbs/stepA_mal.vbs @@ -408,11 +408,13 @@ Sub REPL() End If If Err.Number <> 0 Then If Err.Source = "MThrow" Then - WScript.StdErr.WriteLine Err.Source + ": " + _ + '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 Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description End If End If On Error Goto 0 From 40e9447b98e8629d3567fc1e15d66ce24943a4a1 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sat, 8 Jul 2023 12:13:37 +0800 Subject: [PATCH 42/44] remove my ignore path --- .gitignore | 1 - 1 file changed, 1 deletion(-) diff --git a/.gitignore b/.gitignore index 7062d7fd..80c2c84a 100644 --- a/.gitignore +++ b/.gitignore @@ -22,4 +22,3 @@ GRTAGS logs old tmp/ -impls/\#batch/* From b61c6482c263ad77932f4548878f9a75454c1063 Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sat, 8 Jul 2023 12:20:18 +0800 Subject: [PATCH 43/44] update readme --- README.md | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/README.md b/README.md index 3fa1c13d..f16b1d4d 100644 --- a/README.md +++ b/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 From 96cda20bfa487e6f7bfa1e28bc772c0d5e4f7bca Mon Sep 17 00:00:00 2001 From: OldLiu <632171029@qq.com> Date: Sat, 8 Jul 2023 13:03:26 +0800 Subject: [PATCH 44/44] fix print privous return value in repl error --- impls/vbs/step1_read_print.vbs | 7 ++++--- impls/vbs/step2_eval.vbs | 7 ++++--- impls/vbs/step3_env.vbs | 7 ++++--- impls/vbs/step4_if_fn_do.vbs | 7 ++++--- impls/vbs/step5_tco.vbs | 7 ++++--- impls/vbs/step6_file.vbs | 7 ++++--- impls/vbs/step7_quote.vbs | 7 ++++--- impls/vbs/step8_macros.vbs | 7 ++++--- impls/vbs/step9_try.vbs | 7 ++++--- impls/vbs/stepA_mal.vbs | 7 ++++--- 10 files changed, 40 insertions(+), 30 deletions(-) diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs index a54140ec..01757b6e 100644 --- a/impls/vbs/step1_read_print.vbs +++ b/impls/vbs/step1_read_print.vbs @@ -19,12 +19,13 @@ Sub REPL() Dim strRes On Error Resume Next strRes = REP(strCode) - If strRes <> "" Then - WScript.Echo strRes - End If 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 diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs index e6cad481..769a3426 100644 --- a/impls/vbs/step2_eval.vbs +++ b/impls/vbs/step2_eval.vbs @@ -102,12 +102,13 @@ Sub REPL() Dim strRes On Error Resume Next strRes = REP(strCode) - If strRes <> "" Then - WScript.Echo strRes - End If 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 diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs index ddfaf392..eedff1a9 100644 --- a/impls/vbs/step3_env.vbs +++ b/impls/vbs/step3_env.vbs @@ -113,12 +113,13 @@ Sub REPL() Dim strRes On Error Resume Next strRes = REP(strCode) - If strRes <> "" Then - WScript.Echo strRes - End If 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 diff --git a/impls/vbs/step4_if_fn_do.vbs b/impls/vbs/step4_if_fn_do.vbs index fc90594e..d9cb2e89 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -127,12 +127,13 @@ Sub REPL() Dim strRes On Error Resume Next strRes = REP(strCode) - If strRes <> "" Then - WScript.Echo strRes - End If 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 diff --git a/impls/vbs/step5_tco.vbs b/impls/vbs/step5_tco.vbs index bdba9e96..3b77ecac 100644 --- a/impls/vbs/step5_tco.vbs +++ b/impls/vbs/step5_tco.vbs @@ -136,12 +136,13 @@ Sub REPL() Dim strRes On Error Resume Next strRes = REP(strCode) - If strRes <> "" Then - WScript.Echo strRes - End If 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 diff --git a/impls/vbs/step6_file.vbs b/impls/vbs/step6_file.vbs index 1ca114a3..c7cb37ba 100644 --- a/impls/vbs/step6_file.vbs +++ b/impls/vbs/step6_file.vbs @@ -164,12 +164,13 @@ Sub REPL() Dim strRes On Error Resume Next strRes = REP(strCode) - If strRes <> "" Then - WScript.Echo strRes - End If 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 diff --git a/impls/vbs/step7_quote.vbs b/impls/vbs/step7_quote.vbs index 6d6365c0..4dadef08 100644 --- a/impls/vbs/step7_quote.vbs +++ b/impls/vbs/step7_quote.vbs @@ -288,12 +288,13 @@ Sub REPL() Dim strRes On Error Resume Next strRes = REP(strCode) - If strRes <> "" Then - WScript.Echo strRes - End If 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 diff --git a/impls/vbs/step8_macros.vbs b/impls/vbs/step8_macros.vbs index 7b54d2f6..ed02107a 100644 --- a/impls/vbs/step8_macros.vbs +++ b/impls/vbs/step8_macros.vbs @@ -342,12 +342,13 @@ Sub REPL() Dim strRes On Error Resume Next strRes = REP(strCode) - If strRes <> "" Then - WScript.Echo strRes - End If 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 diff --git a/impls/vbs/step9_try.vbs b/impls/vbs/step9_try.vbs index 6c309a9f..8b4af962 100644 --- a/impls/vbs/step9_try.vbs +++ b/impls/vbs/step9_try.vbs @@ -402,9 +402,6 @@ Sub REPL() Dim strRes On Error Resume Next strRes = REP(strCode) - If strRes <> "" Then - WScript.Echo strRes - End If If Err.Number <> 0 Then If Err.Source = "MThrow" Then 'WScript.StdErr.WriteLine Err.Source + ": " + _ @@ -415,6 +412,10 @@ Sub REPL() '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 diff --git a/impls/vbs/stepA_mal.vbs b/impls/vbs/stepA_mal.vbs index 542f5f26..d6bc3f3d 100644 --- a/impls/vbs/stepA_mal.vbs +++ b/impls/vbs/stepA_mal.vbs @@ -403,9 +403,6 @@ Sub REPL() Dim strRes On Error Resume Next strRes = REP(strCode) - If strRes <> "" Then - WScript.Echo strRes - End If If Err.Number <> 0 Then If Err.Source = "MThrow" Then 'WScript.StdErr.WriteLine Err.Source + ": " + _ @@ -416,6 +413,10 @@ Sub REPL() '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